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();
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();
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 void
Perl_no_bareword_filehandle(pTHX_ const char * fhname)716 Perl_no_bareword_filehandle(pTHX_ const char *fhname) {
717 PERL_ARGS_ASSERT_NO_BAREWORD_FILEHANDLE;
718
719 if (strNE(fhname, "STDERR")
720 && strNE(fhname, "STDOUT")
721 && strNE(fhname, "STDIN")
722 && strNE(fhname, "_")
723 && strNE(fhname, "ARGV")
724 && strNE(fhname, "ARGVOUT")
725 && strNE(fhname, "DATA")) {
726 qerror(Perl_mess(aTHX_ "Bareword filehandle \"%s\" not allowed under 'no feature \"bareword_filehandles\"'", fhname));
727 }
728 }
729
730 /* "register" allocation */
731
732 PADOFFSET
Perl_allocmy(pTHX_ const char * const name,const STRLEN len,const U32 flags)733 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
734 {
735 PADOFFSET off;
736 bool is_idfirst, is_default;
737 const bool is_our = (PL_parser->in_my == KEY_our);
738
739 PERL_ARGS_ASSERT_ALLOCMY;
740
741 if (flags & ~SVf_UTF8)
742 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
743 (UV)flags);
744
745 is_idfirst = flags & SVf_UTF8
746 ? isIDFIRST_utf8_safe((U8*)name + 1, name + len)
747 : isIDFIRST_A(name[1]);
748
749 /* $_, @_, etc. */
750 is_default = len == 2 && name[1] == '_';
751
752 /* complain about "my $<special_var>" etc etc */
753 if (!is_our && (!is_idfirst || is_default)) {
754 const char * const type =
755 PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
756 PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
757
758 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
759 && isASCII(name[1])
760 && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) {
761 /* diag_listed_as: Can't use global %s in %s */
762 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
763 name[0], toCTRL(name[1]),
764 (int)(len - 2), name + 2,
765 type));
766 } else {
767 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
768 (int) len, name,
769 type), flags & SVf_UTF8);
770 }
771 }
772
773 /* allocate a spare slot and store the name in that slot */
774
775 U32 addflags = 0;
776 if(is_our)
777 addflags |= padadd_OUR;
778 else if(PL_parser->in_my == KEY_state)
779 addflags |= padadd_STATE;
780 else if(PL_parser->in_my == KEY_field)
781 addflags |= padadd_FIELD;
782
783 off = pad_add_name_pvn(name, len, addflags,
784 PL_parser->in_my_stash,
785 (is_our
786 /* $_ is always in main::, even with our */
787 ? (PL_curstash && !memEQs(name,len,"$_")
788 ? PL_curstash
789 : PL_defstash)
790 : NULL
791 )
792 );
793 /* anon sub prototypes contains state vars should always be cloned,
794 * otherwise the state var would be shared between anon subs */
795
796 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
797 CvCLONE_on(PL_compcv);
798
799 return off;
800 }
801
802 /*
803 =for apidoc_section $optree_manipulation
804
805 =for apidoc alloccopstash
806
807 Available only under threaded builds, this function allocates an entry in
808 C<PL_stashpad> for the stash passed to it.
809
810 =cut
811 */
812
813 #ifdef USE_ITHREADS
814 PADOFFSET
Perl_alloccopstash(pTHX_ HV * hv)815 Perl_alloccopstash(pTHX_ HV *hv)
816 {
817 PADOFFSET off = 0, o = 1;
818 bool found_slot = FALSE;
819
820 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
821
822 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
823
824 for (; o < PL_stashpadmax; ++o) {
825 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
826 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
827 found_slot = TRUE, off = o;
828 }
829 if (!found_slot) {
830 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
831 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
832 off = PL_stashpadmax;
833 PL_stashpadmax += 10;
834 }
835
836 PL_stashpad[PL_stashpadix = off] = hv;
837 return off;
838 }
839 #endif
840
841 /* free the body of an op without examining its contents.
842 * Always use this rather than FreeOp directly */
843
844 static void
S_op_destroy(pTHX_ OP * o)845 S_op_destroy(pTHX_ OP *o)
846 {
847 FreeOp(o);
848 }
849
850 /* Destructor */
851
852 /*
853 =for apidoc op_free
854
855 Free an op and its children. Only use this when an op is no longer linked
856 to from any optree.
857
858 Remember that any op with C<OPf_KIDS> set is expected to have a valid
859 C<op_first> pointer. If you are attempting to free an op but preserve its
860 child op, make sure to clear that flag before calling C<op_free()>. For
861 example:
862
863 OP *kid = o->op_first; o->op_first = NULL;
864 o->op_flags &= ~OPf_KIDS;
865 op_free(o);
866
867 =cut
868 */
869
870 void
Perl_op_free(pTHX_ OP * o)871 Perl_op_free(pTHX_ OP *o)
872 {
873 OPCODE type;
874 OP *top_op = o;
875 OP *next_op = o;
876 bool went_up = FALSE; /* whether we reached the current node by
877 following the parent pointer from a child, and
878 so have already seen this node */
879
880 if (!o || o->op_type == OP_FREED)
881 return;
882
883 if (o->op_private & OPpREFCOUNTED) {
884 /* if base of tree is refcounted, just decrement */
885 switch (o->op_type) {
886 case OP_LEAVESUB:
887 case OP_LEAVESUBLV:
888 case OP_LEAVEEVAL:
889 case OP_LEAVE:
890 case OP_SCOPE:
891 case OP_LEAVEWRITE:
892 {
893 PADOFFSET refcnt;
894 OP_REFCNT_LOCK;
895 refcnt = OpREFCNT_dec(o);
896 OP_REFCNT_UNLOCK;
897 if (refcnt) {
898 /* Need to find and remove any pattern match ops from
899 * the list we maintain for reset(). */
900 find_and_forget_pmops(o);
901 return;
902 }
903 }
904 break;
905 default:
906 break;
907 }
908 }
909
910 while (next_op) {
911 o = next_op;
912
913 /* free child ops before ourself, (then free ourself "on the
914 * way back up") */
915
916 /* Ensure the caller maintains the relationship between OPf_KIDS and
917 * op_first != NULL when restructuring the tree
918 * https://github.com/Perl/perl5/issues/20764
919 */
920 assert(!(o->op_flags & OPf_KIDS) || cUNOPo->op_first);
921
922 if (!went_up && o->op_flags & OPf_KIDS) {
923 next_op = cUNOPo->op_first;
924 continue;
925 }
926
927 /* find the next node to visit, *then* free the current node
928 * (can't rely on o->op_* fields being valid after o has been
929 * freed) */
930
931 /* The next node to visit will be either the sibling, or the
932 * parent if no siblings left, or NULL if we've worked our way
933 * back up to the top node in the tree */
934 next_op = (o == top_op) ? NULL : o->op_sibparent;
935 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
936
937 /* Now process the current node */
938
939 /* Though ops may be freed twice, freeing the op after its slab is a
940 big no-no. */
941 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
942 /* During the forced freeing of ops after compilation failure, kidops
943 may be freed before their parents. */
944 if (!o || o->op_type == OP_FREED)
945 continue;
946
947 type = o->op_type;
948
949 /* an op should only ever acquire op_private flags that we know about.
950 * If this fails, you may need to fix something in regen/op_private.
951 * Don't bother testing if:
952 * * the op_ppaddr doesn't match the op; someone may have
953 * overridden the op and be doing strange things with it;
954 * * we've errored, as op flags are often left in an
955 * inconsistent state then. Note that an error when
956 * compiling the main program leaves PL_parser NULL, so
957 * we can't spot faults in the main code, only
958 * evaled/required code;
959 * * it's a banned op - we may be croaking before the op is
960 * fully formed. - see CHECKOP. */
961 #ifdef DEBUGGING
962 if ( o->op_ppaddr == PL_ppaddr[type]
963 && PL_parser
964 && !PL_parser->error_count
965 && !(PL_op_mask && PL_op_mask[type])
966 )
967 {
968 assert(!(o->op_private & ~PL_op_private_valid[type]));
969 }
970 #endif
971
972
973 /* Call the op_free hook if it has been set. Do it now so that it's called
974 * at the right time for refcounted ops, but still before all of the kids
975 * are freed. */
976 CALL_OPFREEHOOK(o);
977
978 if (type == OP_NULL)
979 type = (OPCODE)o->op_targ;
980
981 if (o->op_slabbed)
982 Slab_to_rw(OpSLAB(o));
983
984 /* COP* is not cleared by op_clear() so that we may track line
985 * numbers etc even after null() */
986 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
987 cop_free((COP*)o);
988 }
989
990 op_clear(o);
991 FreeOp(o);
992 if (PL_op == o)
993 PL_op = NULL;
994 }
995 }
996
997
998 /* S_op_clear_gv(): free a GV attached to an OP */
999
1000 STATIC
1001 #ifdef USE_ITHREADS
S_op_clear_gv(pTHX_ OP * o,PADOFFSET * ixp)1002 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
1003 #else
1004 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
1005 #endif
1006 {
1007
1008 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
1009 || o->op_type == OP_MULTIDEREF)
1010 #ifdef USE_ITHREADS
1011 && PL_curpad
1012 ? ((GV*)PAD_SVl(*ixp)) : NULL;
1013 #else
1014 ? (GV*)(*svp) : NULL;
1015 #endif
1016 /* It's possible during global destruction that the GV is freed
1017 before the optree. Whilst the SvREFCNT_inc is happy to bump from
1018 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
1019 will trigger an assertion failure, because the entry to sv_clear
1020 checks that the scalar is not already freed. A check of for
1021 !SvIS_FREED(gv) turns out to be invalid, because during global
1022 destruction the reference count can be forced down to zero
1023 (with SVf_BREAK set). In which case raising to 1 and then
1024 dropping to 0 triggers cleanup before it should happen. I
1025 *think* that this might actually be a general, systematic,
1026 weakness of the whole idea of SVf_BREAK, in that code *is*
1027 allowed to raise and lower references during global destruction,
1028 so any *valid* code that happens to do this during global
1029 destruction might well trigger premature cleanup. */
1030 bool still_valid = gv && SvREFCNT(gv);
1031
1032 if (still_valid)
1033 SvREFCNT_inc_simple_void(gv);
1034 #ifdef USE_ITHREADS
1035 if (*ixp > 0) {
1036 pad_swipe(*ixp, TRUE);
1037 *ixp = 0;
1038 }
1039 #else
1040 SvREFCNT_dec(*svp);
1041 *svp = NULL;
1042 #endif
1043 if (still_valid) {
1044 int try_downgrade = SvREFCNT(gv) == 2;
1045 SvREFCNT_dec_NN(gv);
1046 if (try_downgrade)
1047 gv_try_downgrade(gv);
1048 }
1049 }
1050
1051
1052 void
Perl_op_clear(pTHX_ OP * o)1053 Perl_op_clear(pTHX_ OP *o)
1054 {
1055
1056
1057 PERL_ARGS_ASSERT_OP_CLEAR;
1058
1059 switch (o->op_type) {
1060 case OP_NULL: /* Was holding old type, if any. */
1061 /* FALLTHROUGH */
1062 case OP_ENTERTRY:
1063 case OP_ENTEREVAL: /* Was holding hints. */
1064 case OP_ARGDEFELEM: /* Was holding signature index. */
1065 o->op_targ = 0;
1066 break;
1067 default:
1068 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1069 break;
1070 /* FALLTHROUGH */
1071 case OP_GVSV:
1072 case OP_GV:
1073 case OP_AELEMFAST:
1074 #ifdef USE_ITHREADS
1075 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1076 #else
1077 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1078 #endif
1079 break;
1080 case OP_METHOD_REDIR:
1081 case OP_METHOD_REDIR_SUPER:
1082 #ifdef USE_ITHREADS
1083 if (cMETHOPo->op_rclass_targ) {
1084 pad_swipe(cMETHOPo->op_rclass_targ, 1);
1085 cMETHOPo->op_rclass_targ = 0;
1086 }
1087 #else
1088 SvREFCNT_dec(cMETHOPo->op_rclass_sv);
1089 cMETHOPo->op_rclass_sv = NULL;
1090 #endif
1091 /* FALLTHROUGH */
1092 case OP_METHOD_NAMED:
1093 case OP_METHOD_SUPER:
1094 SvREFCNT_dec(cMETHOPo->op_u.op_meth_sv);
1095 cMETHOPo->op_u.op_meth_sv = NULL;
1096 #ifdef USE_ITHREADS
1097 if (o->op_targ) {
1098 pad_swipe(o->op_targ, 1);
1099 o->op_targ = 0;
1100 }
1101 #endif
1102 break;
1103 case OP_CONST:
1104 case OP_HINTSEVAL:
1105 SvREFCNT_dec(cSVOPo->op_sv);
1106 cSVOPo->op_sv = NULL;
1107 #ifdef USE_ITHREADS
1108 /** Bug #15654
1109 Even if op_clear does a pad_free for the target of the op,
1110 pad_free doesn't actually remove the sv that exists in the pad;
1111 instead it lives on. This results in that it could be reused as
1112 a target later on when the pad was reallocated.
1113 **/
1114 if(o->op_targ) {
1115 pad_swipe(o->op_targ,1);
1116 o->op_targ = 0;
1117 }
1118 #endif
1119 break;
1120 case OP_DUMP:
1121 case OP_GOTO:
1122 case OP_NEXT:
1123 case OP_LAST:
1124 case OP_REDO:
1125 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1126 break;
1127 /* FALLTHROUGH */
1128 case OP_TRANS:
1129 case OP_TRANSR:
1130 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1131 && (o->op_private & OPpTRANS_USE_SVOP))
1132 {
1133 #ifdef USE_ITHREADS
1134 if (cPADOPo->op_padix > 0) {
1135 pad_swipe(cPADOPo->op_padix, TRUE);
1136 cPADOPo->op_padix = 0;
1137 }
1138 #else
1139 SvREFCNT_dec(cSVOPo->op_sv);
1140 cSVOPo->op_sv = NULL;
1141 #endif
1142 }
1143 else {
1144 PerlMemShared_free(cPVOPo->op_pv);
1145 cPVOPo->op_pv = NULL;
1146 }
1147 break;
1148 case OP_SUBST:
1149 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1150 goto clear_pmop;
1151
1152 case OP_SPLIT:
1153 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1154 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1155 {
1156 if (o->op_private & OPpSPLIT_LEX)
1157 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1158 else
1159 #ifdef USE_ITHREADS
1160 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1161 #else
1162 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1163 #endif
1164 }
1165 /* FALLTHROUGH */
1166 case OP_MATCH:
1167 case OP_QR:
1168 clear_pmop:
1169 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1170 op_free(cPMOPo->op_code_list);
1171 cPMOPo->op_code_list = NULL;
1172 forget_pmop(cPMOPo);
1173 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1174 /* we use the same protection as the "SAFE" version of the PM_ macros
1175 * here since sv_clean_all might release some PMOPs
1176 * after PL_regex_padav has been cleared
1177 * and the clearing of PL_regex_padav needs to
1178 * happen before sv_clean_all
1179 */
1180 #ifdef USE_ITHREADS
1181 if(PL_regex_pad) { /* We could be in destruction */
1182 const IV offset = (cPMOPo)->op_pmoffset;
1183 ReREFCNT_dec(PM_GETRE(cPMOPo));
1184 PL_regex_pad[offset] = &PL_sv_undef;
1185 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1186 sizeof(offset));
1187 }
1188 #else
1189 ReREFCNT_dec(PM_GETRE(cPMOPo));
1190 PM_SETRE(cPMOPo, NULL);
1191 #endif
1192
1193 break;
1194
1195 case OP_ARGCHECK:
1196 PerlMemShared_free(cUNOP_AUXo->op_aux);
1197 break;
1198
1199 case OP_MULTICONCAT:
1200 {
1201 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1202 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1203 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1204 * utf8 shared strings */
1205 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1206 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1207 if (p1)
1208 PerlMemShared_free(p1);
1209 if (p2 && p1 != p2)
1210 PerlMemShared_free(p2);
1211 PerlMemShared_free(aux);
1212 }
1213 break;
1214
1215 case OP_MULTIDEREF:
1216 {
1217 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1218 UV actions = items->uv;
1219 bool last = 0;
1220 bool is_hash = FALSE;
1221
1222 while (!last) {
1223 switch (actions & MDEREF_ACTION_MASK) {
1224
1225 case MDEREF_reload:
1226 actions = (++items)->uv;
1227 continue;
1228
1229 case MDEREF_HV_padhv_helem:
1230 is_hash = TRUE;
1231 /* FALLTHROUGH */
1232 case MDEREF_AV_padav_aelem:
1233 pad_free((++items)->pad_offset);
1234 goto do_elem;
1235
1236 case MDEREF_HV_gvhv_helem:
1237 is_hash = TRUE;
1238 /* FALLTHROUGH */
1239 case MDEREF_AV_gvav_aelem:
1240 #ifdef USE_ITHREADS
1241 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1242 #else
1243 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1244 #endif
1245 goto do_elem;
1246
1247 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1248 is_hash = TRUE;
1249 /* FALLTHROUGH */
1250 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1251 #ifdef USE_ITHREADS
1252 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1253 #else
1254 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1255 #endif
1256 goto do_vivify_rv2xv_elem;
1257
1258 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1259 is_hash = TRUE;
1260 /* FALLTHROUGH */
1261 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1262 pad_free((++items)->pad_offset);
1263 goto do_vivify_rv2xv_elem;
1264
1265 case MDEREF_HV_pop_rv2hv_helem:
1266 case MDEREF_HV_vivify_rv2hv_helem:
1267 is_hash = TRUE;
1268 /* FALLTHROUGH */
1269 do_vivify_rv2xv_elem:
1270 case MDEREF_AV_pop_rv2av_aelem:
1271 case MDEREF_AV_vivify_rv2av_aelem:
1272 do_elem:
1273 switch (actions & MDEREF_INDEX_MASK) {
1274 case MDEREF_INDEX_none:
1275 last = 1;
1276 break;
1277 case MDEREF_INDEX_const:
1278 if (is_hash) {
1279 #ifdef USE_ITHREADS
1280 /* see RT #15654 */
1281 pad_swipe((++items)->pad_offset, 1);
1282 #else
1283 SvREFCNT_dec((++items)->sv);
1284 #endif
1285 }
1286 else
1287 items++;
1288 break;
1289 case MDEREF_INDEX_padsv:
1290 pad_free((++items)->pad_offset);
1291 break;
1292 case MDEREF_INDEX_gvsv:
1293 #ifdef USE_ITHREADS
1294 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1295 #else
1296 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1297 #endif
1298 break;
1299 }
1300
1301 if (actions & MDEREF_FLAG_last)
1302 last = 1;
1303 is_hash = FALSE;
1304
1305 break;
1306
1307 default:
1308 assert(0);
1309 last = 1;
1310 break;
1311
1312 } /* switch */
1313
1314 actions >>= MDEREF_SHIFT;
1315 } /* while */
1316
1317 /* start of malloc is at op_aux[-1], where the length is
1318 * stored */
1319 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1320 }
1321 break;
1322
1323 case OP_METHSTART:
1324 {
1325 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1326 /* Every item in aux is a UV, so nothing in it to free */
1327 Safefree(aux);
1328 }
1329 break;
1330
1331 case OP_INITFIELD:
1332 {
1333 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1334 /* Every item in aux is a UV, so nothing in it to free */
1335 Safefree(aux);
1336 }
1337 break;
1338 }
1339
1340 if (o->op_targ > 0) {
1341 pad_free(o->op_targ);
1342 o->op_targ = 0;
1343 }
1344 }
1345
1346 STATIC void
S_cop_free(pTHX_ COP * cop)1347 S_cop_free(pTHX_ COP* cop)
1348 {
1349 PERL_ARGS_ASSERT_COP_FREE;
1350
1351 /* If called during global destruction PL_defstash might be NULL and there
1352 shouldn't be any code running that will trip over the bad cop address.
1353 This also avoids uselessly creating the AV after it's been destroyed.
1354 */
1355 if (cop->op_type == OP_DBSTATE && PL_phase != PERL_PHASE_DESTRUCT) {
1356 /* Remove the now invalid op from the line number information.
1357 This could cause a freed memory overwrite if the debugger tried to
1358 set a breakpoint on this line.
1359 */
1360 AV *av = CopFILEAVn(cop);
1361 if (av) {
1362 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
1363 if (svp && *svp != &PL_sv_undef && SvIVX(*svp) == PTR2IV(cop) ) {
1364 (void)SvIOK_off(*svp);
1365 SvIV_set(*svp, 0);
1366 }
1367 }
1368 }
1369 CopFILE_free(cop);
1370 if (! specialWARN(cop->cop_warnings))
1371 cop->cop_warnings = rcpv_free(cop->cop_warnings);
1372
1373 cophh_free(CopHINTHASH_get(cop));
1374 if (PL_curcop == cop)
1375 PL_curcop = NULL;
1376 }
1377
1378 STATIC void
S_forget_pmop(pTHX_ PMOP * const o)1379 S_forget_pmop(pTHX_ PMOP *const o)
1380 {
1381 HV * const pmstash = PmopSTASH(o);
1382
1383 PERL_ARGS_ASSERT_FORGET_PMOP;
1384
1385 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1386 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1387 if (mg) {
1388 PMOP **const array = (PMOP**) mg->mg_ptr;
1389 U32 count = mg->mg_len / sizeof(PMOP**);
1390 U32 i = count;
1391
1392 while (i--) {
1393 if (array[i] == o) {
1394 /* Found it. Move the entry at the end to overwrite it. */
1395 array[i] = array[--count];
1396 mg->mg_len = count * sizeof(PMOP**);
1397 /* Could realloc smaller at this point always, but probably
1398 not worth it. Probably worth free()ing if we're the
1399 last. */
1400 if(!count) {
1401 Safefree(mg->mg_ptr);
1402 mg->mg_ptr = NULL;
1403 }
1404 break;
1405 }
1406 }
1407 }
1408 }
1409 if (PL_curpm == o)
1410 PL_curpm = NULL;
1411 }
1412
1413
1414 STATIC void
S_find_and_forget_pmops(pTHX_ OP * o)1415 S_find_and_forget_pmops(pTHX_ OP *o)
1416 {
1417 OP* top_op = o;
1418
1419 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1420
1421 while (1) {
1422 switch (o->op_type) {
1423 case OP_SUBST:
1424 case OP_SPLIT:
1425 case OP_MATCH:
1426 case OP_QR:
1427 forget_pmop(cPMOPo);
1428 }
1429
1430 if (o->op_flags & OPf_KIDS) {
1431 o = cUNOPo->op_first;
1432 continue;
1433 }
1434
1435 while (1) {
1436 if (o == top_op)
1437 return; /* at top; no parents/siblings to try */
1438 if (OpHAS_SIBLING(o)) {
1439 o = o->op_sibparent; /* process next sibling */
1440 break;
1441 }
1442 o = o->op_sibparent; /*try parent's next sibling */
1443 }
1444 }
1445 }
1446
1447
1448 /*
1449 =for apidoc op_null
1450
1451 Neutralizes an op when it is no longer needed, but is still linked to from
1452 other ops.
1453
1454 =cut
1455 */
1456
1457 void
Perl_op_null(pTHX_ OP * o)1458 Perl_op_null(pTHX_ OP *o)
1459 {
1460
1461 PERL_ARGS_ASSERT_OP_NULL;
1462
1463 if (o->op_type == OP_NULL)
1464 return;
1465 op_clear(o);
1466 o->op_targ = o->op_type;
1467 OpTYPE_set(o, OP_NULL);
1468 }
1469
1470 /*
1471 =for apidoc op_refcnt_lock
1472
1473 Implements the C<OP_REFCNT_LOCK> macro which you should use instead.
1474
1475 =cut
1476 */
1477
1478 void
Perl_op_refcnt_lock(pTHX)1479 Perl_op_refcnt_lock(pTHX)
1480 PERL_TSA_ACQUIRE(PL_op_mutex)
1481 {
1482 PERL_UNUSED_CONTEXT;
1483 OP_REFCNT_LOCK;
1484 }
1485
1486 /*
1487 =for apidoc op_refcnt_unlock
1488
1489 Implements the C<OP_REFCNT_UNLOCK> macro which you should use instead.
1490
1491 =cut
1492 */
1493
1494 void
Perl_op_refcnt_unlock(pTHX)1495 Perl_op_refcnt_unlock(pTHX)
1496 PERL_TSA_RELEASE(PL_op_mutex)
1497 {
1498 PERL_UNUSED_CONTEXT;
1499 OP_REFCNT_UNLOCK;
1500 }
1501
1502
1503 /*
1504 =for apidoc op_sibling_splice
1505
1506 A general function for editing the structure of an existing chain of
1507 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1508 you to delete zero or more sequential nodes, replacing them with zero or
1509 more different nodes. Performs the necessary op_first/op_last
1510 housekeeping on the parent node and op_sibling manipulation on the
1511 children. The last deleted node will be marked as the last node by
1512 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1513
1514 Note that op_next is not manipulated, and nodes are not freed; that is the
1515 responsibility of the caller. It also won't create a new list op for an
1516 empty list etc; use higher-level functions like op_append_elem() for that.
1517
1518 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1519 the splicing doesn't affect the first or last op in the chain.
1520
1521 C<start> is the node preceding the first node to be spliced. Node(s)
1522 following it will be deleted, and ops will be inserted after it. If it is
1523 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1524 beginning.
1525
1526 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1527 If -1 or greater than or equal to the number of remaining kids, all
1528 remaining kids are deleted.
1529
1530 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1531 If C<NULL>, no nodes are inserted.
1532
1533 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1534 deleted.
1535
1536 For example:
1537
1538 action before after returns
1539 ------ ----- ----- -------
1540
1541 P P
1542 splice(P, A, 2, X-Y-Z) | | B-C
1543 A-B-C-D A-X-Y-Z-D
1544
1545 P P
1546 splice(P, NULL, 1, X-Y) | | A
1547 A-B-C-D X-Y-B-C-D
1548
1549 P P
1550 splice(P, NULL, 3, NULL) | | A-B-C
1551 A-B-C-D D
1552
1553 P P
1554 splice(P, B, 0, X-Y) | | NULL
1555 A-B-C-D A-B-X-Y-C-D
1556
1557
1558 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1559 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1560
1561 =cut
1562 */
1563
1564 OP *
Perl_op_sibling_splice(OP * parent,OP * start,int del_count,OP * insert)1565 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1566 {
1567 OP *first;
1568 OP *rest;
1569 OP *last_del = NULL;
1570 OP *last_ins = NULL;
1571
1572 if (start)
1573 first = OpSIBLING(start);
1574 else if (!parent)
1575 goto no_parent;
1576 else
1577 first = cLISTOPx(parent)->op_first;
1578
1579 assert(del_count >= -1);
1580
1581 if (del_count && first) {
1582 last_del = first;
1583 while (--del_count && OpHAS_SIBLING(last_del))
1584 last_del = OpSIBLING(last_del);
1585 rest = OpSIBLING(last_del);
1586 OpLASTSIB_set(last_del, NULL);
1587 }
1588 else
1589 rest = first;
1590
1591 if (insert) {
1592 last_ins = insert;
1593 while (OpHAS_SIBLING(last_ins))
1594 last_ins = OpSIBLING(last_ins);
1595 OpMAYBESIB_set(last_ins, rest, NULL);
1596 }
1597 else
1598 insert = rest;
1599
1600 if (start) {
1601 OpMAYBESIB_set(start, insert, NULL);
1602 }
1603 else {
1604 assert(parent);
1605 cLISTOPx(parent)->op_first = insert;
1606 if (insert)
1607 parent->op_flags |= OPf_KIDS;
1608 else
1609 parent->op_flags &= ~OPf_KIDS;
1610 }
1611
1612 if (!rest) {
1613 /* update op_last etc */
1614 U32 type;
1615 OP *lastop;
1616
1617 if (!parent)
1618 goto no_parent;
1619
1620 /* ought to use OP_CLASS(parent) here, but that can't handle
1621 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1622 * either */
1623 type = parent->op_type;
1624 if (type == OP_CUSTOM) {
1625 dTHX;
1626 type = XopENTRYCUSTOM(parent, xop_class);
1627 }
1628 else {
1629 if (type == OP_NULL)
1630 type = parent->op_targ;
1631 type = PL_opargs[type] & OA_CLASS_MASK;
1632 }
1633
1634 lastop = last_ins ? last_ins : start ? start : NULL;
1635 if ( type == OA_BINOP
1636 || type == OA_LISTOP
1637 || type == OA_PMOP
1638 || type == OA_LOOP
1639 )
1640 cLISTOPx(parent)->op_last = lastop;
1641
1642 if (lastop)
1643 OpLASTSIB_set(lastop, parent);
1644 }
1645 return last_del ? first : NULL;
1646
1647 no_parent:
1648 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1649 }
1650
1651 /*
1652 =for apidoc op_parent
1653
1654 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1655
1656 =cut
1657 */
1658
1659 OP *
Perl_op_parent(OP * o)1660 Perl_op_parent(OP *o)
1661 {
1662 PERL_ARGS_ASSERT_OP_PARENT;
1663 while (OpHAS_SIBLING(o))
1664 o = OpSIBLING(o);
1665 return o->op_sibparent;
1666 }
1667
1668 /* replace the sibling following start with a new UNOP, which becomes
1669 * the parent of the original sibling; e.g.
1670 *
1671 * op_sibling_newUNOP(P, A, unop-args...)
1672 *
1673 * P P
1674 * | becomes |
1675 * A-B-C A-U-C
1676 * |
1677 * B
1678 *
1679 * where U is the new UNOP.
1680 *
1681 * parent and start args are the same as for op_sibling_splice();
1682 * type and flags args are as newUNOP().
1683 *
1684 * Returns the new UNOP.
1685 */
1686
1687 STATIC OP *
S_op_sibling_newUNOP(pTHX_ OP * parent,OP * start,I32 type,I32 flags)1688 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1689 {
1690 OP *kid, *newop;
1691
1692 kid = op_sibling_splice(parent, start, 1, NULL);
1693 newop = newUNOP(type, flags, kid);
1694 op_sibling_splice(parent, start, 0, newop);
1695 return newop;
1696 }
1697
1698
1699 /* lowest-level newLOGOP-style function - just allocates and populates
1700 * the struct. Higher-level stuff should be done by S_new_logop() /
1701 * newLOGOP(). This function exists mainly to avoid op_first assignment
1702 * being spread throughout this file.
1703 */
1704
1705 LOGOP *
Perl_alloc_LOGOP(pTHX_ I32 type,OP * first,OP * other)1706 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1707 {
1708 LOGOP *logop;
1709 OP *kid = first;
1710 NewOp(1101, logop, 1, LOGOP);
1711 OpTYPE_set(logop, type);
1712 logop->op_first = first;
1713 logop->op_other = other;
1714 if (first)
1715 logop->op_flags = OPf_KIDS;
1716 while (kid && OpHAS_SIBLING(kid))
1717 kid = OpSIBLING(kid);
1718 if (kid)
1719 OpLASTSIB_set(kid, (OP*)logop);
1720 return logop;
1721 }
1722
1723
1724 /* Contextualizers */
1725
1726 /*
1727 =for apidoc op_contextualize
1728
1729 Applies a syntactic context to an op tree representing an expression.
1730 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_LIST>,
1731 or C<G_VOID> to specify the context to apply. The modified op tree
1732 is returned.
1733
1734 =cut
1735 */
1736
1737 OP *
Perl_op_contextualize(pTHX_ OP * o,I32 context)1738 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1739 {
1740 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1741 switch (context) {
1742 case G_SCALAR: return scalar(o);
1743 case G_LIST: return list(o);
1744 case G_VOID: return scalarvoid(o);
1745 default:
1746 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1747 (long) context);
1748 }
1749 }
1750
1751 /*
1752
1753 =for apidoc op_linklist
1754 This function is the implementation of the L</LINKLIST> macro. It should
1755 not be called directly.
1756
1757 =cut
1758 */
1759
1760
1761 OP *
Perl_op_linklist(pTHX_ OP * o)1762 Perl_op_linklist(pTHX_ OP *o)
1763 {
1764
1765 OP **prevp;
1766 OP *kid;
1767 OP * top_op = o;
1768
1769 PERL_ARGS_ASSERT_OP_LINKLIST;
1770
1771 while (1) {
1772 /* Descend down the tree looking for any unprocessed subtrees to
1773 * do first */
1774 if (!o->op_next) {
1775 if (o->op_flags & OPf_KIDS) {
1776 o = cUNOPo->op_first;
1777 continue;
1778 }
1779 o->op_next = o; /* leaf node; link to self initially */
1780 }
1781
1782 /* if we're at the top level, there either weren't any children
1783 * to process, or we've worked our way back to the top. */
1784 if (o == top_op)
1785 return o->op_next;
1786
1787 /* o is now processed. Next, process any sibling subtrees */
1788
1789 if (OpHAS_SIBLING(o)) {
1790 o = OpSIBLING(o);
1791 continue;
1792 }
1793
1794 /* Done all the subtrees at this level. Go back up a level and
1795 * link the parent in with all its (processed) children.
1796 */
1797
1798 o = o->op_sibparent;
1799 assert(!o->op_next);
1800 prevp = &(o->op_next);
1801 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1802 while (kid) {
1803 *prevp = kid->op_next;
1804 prevp = &(kid->op_next);
1805 kid = OpSIBLING(kid);
1806 }
1807 *prevp = o;
1808 }
1809 }
1810
1811
1812 static OP *
S_scalarkids(pTHX_ OP * o)1813 S_scalarkids(pTHX_ OP *o)
1814 {
1815 if (o && o->op_flags & OPf_KIDS) {
1816 OP *kid;
1817 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1818 scalar(kid);
1819 }
1820 return o;
1821 }
1822
1823 STATIC OP *
S_scalarboolean(pTHX_ OP * o)1824 S_scalarboolean(pTHX_ OP *o)
1825 {
1826 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1827
1828 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1829 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1830 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1831 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1832 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1833 if (ckWARN(WARN_SYNTAX)) {
1834 const line_t oldline = CopLINE(PL_curcop);
1835
1836 if (PL_parser && PL_parser->copline != NOLINE) {
1837 /* This ensures that warnings are reported at the first line
1838 of the conditional, not the last. */
1839 CopLINE_set(PL_curcop, PL_parser->copline);
1840 }
1841 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1842 CopLINE_set(PL_curcop, oldline);
1843 }
1844 }
1845 return scalar(o);
1846 }
1847
1848 static SV *
S_op_varname_subscript(pTHX_ const OP * o,int subscript_type)1849 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1850 {
1851 assert(o);
1852 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1853 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1854 {
1855 const char funny = o->op_type == OP_PADAV
1856 || o->op_type == OP_RV2AV ? '@' : '%';
1857 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1858 GV *gv;
1859 if (cUNOPo->op_first->op_type != OP_GV
1860 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1861 return NULL;
1862 return varname(gv, funny, 0, NULL, 0, subscript_type);
1863 }
1864 return
1865 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1866 }
1867 }
1868
1869 SV *
Perl_op_varname(pTHX_ const OP * o)1870 Perl_op_varname(pTHX_ const OP *o)
1871 {
1872 PERL_ARGS_ASSERT_OP_VARNAME;
1873
1874 return S_op_varname_subscript(aTHX_ o, 1);
1875 }
1876
1877 /*
1878
1879 Warns that an access of a single element from a named container variable in
1880 scalar context might not be what the programmer wanted. The container
1881 variable's (sigiled, full) name is given by C<name>, and the key to access
1882 it is given by the C<SVOP_sv> of the C<OP_CONST> op given by C<o>.
1883 C<is_hash> selects whether it prints using {KEY} or [KEY] brackets.
1884
1885 C<is_slice> selects between two different messages used in different places.
1886 */
1887 void
Perl_warn_elem_scalar_context(pTHX_ const OP * o,SV * name,bool is_hash,bool is_slice)1888 Perl_warn_elem_scalar_context(pTHX_ const OP *o, SV *name, bool is_hash, bool is_slice)
1889 {
1890 PERL_ARGS_ASSERT_WARN_ELEM_SCALAR_CONTEXT;
1891
1892 SV *keysv = NULL;
1893 const char *keypv = NULL;
1894
1895 const char lbrack = is_hash ? '{' : '[';
1896 const char rbrack = is_hash ? '}' : ']';
1897
1898 if (o->op_type == OP_CONST) {
1899 keysv = cSVOPo_sv;
1900 if (SvPOK(keysv)) {
1901 SV *sv = keysv;
1902 keysv = sv_newmortal();
1903 pv_pretty(keysv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1904 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1905 }
1906 else if (!SvOK(keysv))
1907 keypv = "undef";
1908 }
1909 else keypv = "...";
1910
1911 assert(SvPOK(name));
1912 sv_chop(name,SvPVX(name)+1);
1913
1914 const char *msg;
1915
1916 if (keypv) {
1917 msg = is_slice ?
1918 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1919 PERL_DIAG_WARN_SYNTAX(
1920 "Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c") :
1921 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1922 PERL_DIAG_WARN_SYNTAX(
1923 "%%%" SVf "%c%s%c in scalar context better written as $%" SVf "%c%s%c");
1924
1925 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1926 SVfARG(name), lbrack, keypv, rbrack,
1927 SVfARG(name), lbrack, keypv, rbrack);
1928 }
1929 else {
1930 msg = is_slice ?
1931 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1932 PERL_DIAG_WARN_SYNTAX(
1933 "Scalar value @%" SVf "%c%" SVf "%c better written as $%" SVf "%c%" SVf "%c") :
1934 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1935 PERL_DIAG_WARN_SYNTAX(
1936 "%%%" SVf "%c%" SVf "%c in scalar context better written as $%" SVf "%c%" SVf "%c");
1937
1938 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1939 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1940 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1941 }
1942 }
1943
1944
1945 /* apply scalar context to the o subtree */
1946
1947 OP *
Perl_scalar(pTHX_ OP * o)1948 Perl_scalar(pTHX_ OP *o)
1949 {
1950 OP * top_op = o;
1951
1952 while (1) {
1953 OP *next_kid = NULL; /* what op (if any) to process next */
1954 OP *kid;
1955
1956 /* assumes no premature commitment */
1957 if (!o || (PL_parser && PL_parser->error_count)
1958 || (o->op_flags & OPf_WANT)
1959 || o->op_type == OP_RETURN)
1960 {
1961 goto do_next;
1962 }
1963
1964 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1965
1966 switch (o->op_type) {
1967 case OP_REPEAT:
1968 scalar(cBINOPo->op_first);
1969 /* convert what initially looked like a list repeat into a
1970 * scalar repeat, e.g. $s = (1) x $n
1971 */
1972 if (o->op_private & OPpREPEAT_DOLIST) {
1973 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1974 assert(kid->op_type == OP_PUSHMARK);
1975 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1976 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1977 o->op_private &=~ OPpREPEAT_DOLIST;
1978 }
1979 }
1980 break;
1981
1982 case OP_OR:
1983 case OP_AND:
1984 case OP_COND_EXPR:
1985 /* impose scalar context on everything except the condition */
1986 next_kid = OpSIBLING(cUNOPo->op_first);
1987 break;
1988
1989 default:
1990 if (o->op_flags & OPf_KIDS)
1991 next_kid = cUNOPo->op_first; /* do all kids */
1992 break;
1993
1994 /* the children of these ops are usually a list of statements,
1995 * except the leaves, whose first child is a corresponding enter
1996 */
1997 case OP_SCOPE:
1998 case OP_LINESEQ:
1999 case OP_LIST:
2000 kid = cLISTOPo->op_first;
2001 goto do_kids;
2002 case OP_LEAVE:
2003 case OP_LEAVETRY:
2004 kid = cLISTOPo->op_first;
2005 scalar(kid);
2006 kid = OpSIBLING(kid);
2007 do_kids:
2008 while (kid) {
2009 OP *sib = OpSIBLING(kid);
2010 /* Apply void context to all kids except the last, which
2011 * is scalar (ignoring a trailing ex-nextstate in determining
2012 * if it's the last kid). E.g.
2013 * $scalar = do { void; void; scalar }
2014 * Except that 'when's are always scalar, e.g.
2015 * $scalar = do { given(..) {
2016 * when (..) { scalar }
2017 * when (..) { scalar }
2018 * ...
2019 * }}
2020 */
2021 if (!sib
2022 || ( !OpHAS_SIBLING(sib)
2023 && sib->op_type == OP_NULL
2024 && ( sib->op_targ == OP_NEXTSTATE
2025 || sib->op_targ == OP_DBSTATE )
2026 )
2027 )
2028 {
2029 /* tail call optimise calling scalar() on the last kid */
2030 next_kid = kid;
2031 goto do_next;
2032 }
2033 else if (kid->op_type == OP_LEAVEWHEN)
2034 scalar(kid);
2035 else
2036 scalarvoid(kid);
2037 kid = sib;
2038 }
2039 NOT_REACHED; /* NOTREACHED */
2040 break;
2041
2042 case OP_SORT:
2043 Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR), "Useless use of %s in scalar context", "sort");
2044 break;
2045
2046 case OP_KVHSLICE:
2047 case OP_KVASLICE:
2048 {
2049 /* Warn about scalar context */
2050 SV *name;
2051
2052 /* This warning can be nonsensical when there is a syntax error. */
2053 if (PL_parser && PL_parser->error_count)
2054 break;
2055
2056 if (!ckWARN(WARN_SYNTAX)) break;
2057
2058 kid = cLISTOPo->op_first;
2059 kid = OpSIBLING(kid); /* get past pushmark */
2060 assert(OpSIBLING(kid));
2061 name = op_varname(OpSIBLING(kid));
2062 if (!name) /* XS module fiddling with the op tree */
2063 break;
2064 warn_elem_scalar_context(kid, name, o->op_type == OP_KVHSLICE, false);
2065 }
2066 } /* switch */
2067
2068 /* If next_kid is set, someone in the code above wanted us to process
2069 * that kid and all its remaining siblings. Otherwise, work our way
2070 * back up the tree */
2071 do_next:
2072 while (!next_kid) {
2073 if (o == top_op)
2074 return top_op; /* at top; no parents/siblings to try */
2075 if (OpHAS_SIBLING(o))
2076 next_kid = o->op_sibparent;
2077 else {
2078 o = o->op_sibparent; /*try parent's next sibling */
2079 switch (o->op_type) {
2080 case OP_SCOPE:
2081 case OP_LINESEQ:
2082 case OP_LIST:
2083 case OP_LEAVE:
2084 case OP_LEAVETRY:
2085 /* should really restore PL_curcop to its old value, but
2086 * setting it to PL_compiling is better than do nothing */
2087 PL_curcop = &PL_compiling;
2088 }
2089 }
2090 }
2091 o = next_kid;
2092 } /* while */
2093 }
2094
2095
2096 /* apply void context to the optree arg */
2097
2098 OP *
Perl_scalarvoid(pTHX_ OP * arg)2099 Perl_scalarvoid(pTHX_ OP *arg)
2100 {
2101 OP *kid;
2102 SV* sv;
2103 OP *o = arg;
2104
2105 PERL_ARGS_ASSERT_SCALARVOID;
2106
2107 while (1) {
2108 U8 want;
2109 SV *useless_sv = NULL;
2110 const char* useless = NULL;
2111 OP * next_kid = NULL;
2112
2113 if (o->op_type == OP_NEXTSTATE
2114 || o->op_type == OP_DBSTATE
2115 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2116 || o->op_targ == OP_DBSTATE)))
2117 PL_curcop = (COP*)o; /* for warning below */
2118
2119 /* assumes no premature commitment */
2120 want = o->op_flags & OPf_WANT;
2121 if ((want && want != OPf_WANT_SCALAR)
2122 || (PL_parser && PL_parser->error_count)
2123 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2124 {
2125 goto get_next_op;
2126 }
2127
2128 if ((o->op_private & OPpTARGET_MY)
2129 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2130 {
2131 /* newASSIGNOP has already applied scalar context, which we
2132 leave, as if this op is inside SASSIGN. */
2133 goto get_next_op;
2134 }
2135
2136 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2137
2138 switch (o->op_type) {
2139 default:
2140 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2141 break;
2142 /* FALLTHROUGH */
2143 case OP_REPEAT:
2144 if (o->op_flags & OPf_STACKED)
2145 break;
2146 if (o->op_type == OP_REPEAT)
2147 scalar(cBINOPo->op_first);
2148 goto func_ops;
2149 case OP_CONCAT:
2150 if ((o->op_flags & OPf_STACKED) &&
2151 !(o->op_private & OPpCONCAT_NESTED))
2152 break;
2153 goto func_ops;
2154 case OP_SUBSTR:
2155 if (o->op_private == 4)
2156 break;
2157 /* FALLTHROUGH */
2158 case OP_WANTARRAY:
2159 case OP_GV:
2160 case OP_SMARTMATCH:
2161 case OP_AV2ARYLEN:
2162 case OP_REF:
2163 case OP_REFGEN:
2164 case OP_SREFGEN:
2165 case OP_ANONCODE:
2166 case OP_DEFINED:
2167 case OP_HEX:
2168 case OP_OCT:
2169 case OP_LENGTH:
2170 case OP_VEC:
2171 case OP_INDEX:
2172 case OP_RINDEX:
2173 case OP_SPRINTF:
2174 case OP_KVASLICE:
2175 case OP_KVHSLICE:
2176 case OP_UNPACK:
2177 case OP_PACK:
2178 case OP_JOIN:
2179 case OP_LSLICE:
2180 case OP_ANONLIST:
2181 case OP_ANONHASH:
2182 case OP_SORT:
2183 case OP_REVERSE:
2184 case OP_RANGE:
2185 case OP_FLIP:
2186 case OP_FLOP:
2187 case OP_CALLER:
2188 case OP_FILENO:
2189 case OP_EOF:
2190 case OP_TELL:
2191 case OP_GETSOCKNAME:
2192 case OP_GETPEERNAME:
2193 case OP_READLINK:
2194 case OP_TELLDIR:
2195 case OP_GETPPID:
2196 case OP_GETPGRP:
2197 case OP_GETPRIORITY:
2198 case OP_TIME:
2199 case OP_TMS:
2200 case OP_LOCALTIME:
2201 case OP_GMTIME:
2202 case OP_GHBYNAME:
2203 case OP_GHBYADDR:
2204 case OP_GHOSTENT:
2205 case OP_GNBYNAME:
2206 case OP_GNBYADDR:
2207 case OP_GNETENT:
2208 case OP_GPBYNAME:
2209 case OP_GPBYNUMBER:
2210 case OP_GPROTOENT:
2211 case OP_GSBYNAME:
2212 case OP_GSBYPORT:
2213 case OP_GSERVENT:
2214 case OP_GPWNAM:
2215 case OP_GPWUID:
2216 case OP_GGRNAM:
2217 case OP_GGRGID:
2218 case OP_GETLOGIN:
2219 case OP_PROTOTYPE:
2220 case OP_RUNCV:
2221 func_ops:
2222 useless = OP_DESC(o);
2223 break;
2224
2225 case OP_GVSV:
2226 case OP_PADSV:
2227 case OP_PADAV:
2228 case OP_PADHV:
2229 case OP_PADANY:
2230 case OP_AELEM:
2231 case OP_AELEMFAST:
2232 case OP_AELEMFAST_LEX:
2233 case OP_ASLICE:
2234 case OP_HELEM:
2235 case OP_HSLICE:
2236 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2237 /* Otherwise it's "Useless use of grep iterator" */
2238 useless = OP_DESC(o);
2239 break;
2240
2241 case OP_SPLIT:
2242 if (!(o->op_private & OPpSPLIT_ASSIGN))
2243 useless = OP_DESC(o);
2244 break;
2245
2246 case OP_NOT:
2247 kid = cUNOPo->op_first;
2248 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2249 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2250 goto func_ops;
2251 }
2252 useless = "negative pattern binding (!~)";
2253 break;
2254
2255 case OP_SUBST:
2256 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2257 useless = "non-destructive substitution (s///r)";
2258 break;
2259
2260 case OP_TRANSR:
2261 useless = "non-destructive transliteration (tr///r)";
2262 break;
2263
2264 case OP_RV2GV:
2265 case OP_RV2SV:
2266 case OP_RV2AV:
2267 case OP_RV2HV:
2268 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2269 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2270 useless = "a variable";
2271 break;
2272
2273 case OP_CONST:
2274 sv = cSVOPo_sv;
2275 if (cSVOPo->op_private & OPpCONST_STRICT)
2276 no_bareword_allowed(o);
2277 else {
2278 if (ckWARN(WARN_VOID)) {
2279 NV nv;
2280 /* don't warn on optimised away booleans, eg
2281 * use constant Foo, 5; Foo || print; */
2282 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2283 useless = NULL;
2284 /* the constants 0 and 1 are permitted as they are
2285 conventionally used as dummies in constructs like
2286 1 while some_condition_with_side_effects; */
2287 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2288 useless = NULL;
2289 else if (SvPOK(sv)) {
2290 SV * const dsv = newSVpvs("");
2291 useless_sv
2292 = Perl_newSVpvf(aTHX_
2293 "a constant (%s)",
2294 pv_pretty(dsv, SvPVX_const(sv),
2295 SvCUR(sv), 32, NULL, NULL,
2296 PERL_PV_PRETTY_DUMP
2297 | PERL_PV_ESCAPE_NOCLEAR
2298 | PERL_PV_ESCAPE_UNI_DETECT));
2299 SvREFCNT_dec_NN(dsv);
2300 }
2301 else if (SvOK(sv)) {
2302 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2303 }
2304 else
2305 useless = "a constant (undef)";
2306 }
2307 }
2308 op_null(o); /* don't execute or even remember it */
2309 break;
2310
2311 case OP_POSTINC:
2312 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2313 break;
2314
2315 case OP_POSTDEC:
2316 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2317 break;
2318
2319 case OP_I_POSTINC:
2320 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2321 break;
2322
2323 case OP_I_POSTDEC:
2324 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2325 break;
2326
2327 case OP_SASSIGN: {
2328 OP *rv2gv;
2329 UNOP *refgen, *rv2cv;
2330 LISTOP *exlist;
2331
2332 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2333 break;
2334
2335 rv2gv = cBINOPo->op_last;
2336 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2337 break;
2338
2339 refgen = cUNOPx(cBINOPo->op_first);
2340
2341 if (!refgen || (refgen->op_type != OP_REFGEN
2342 && refgen->op_type != OP_SREFGEN))
2343 break;
2344
2345 exlist = cLISTOPx(refgen->op_first);
2346 if (!exlist || exlist->op_type != OP_NULL
2347 || exlist->op_targ != OP_LIST)
2348 break;
2349
2350 if (exlist->op_first->op_type != OP_PUSHMARK
2351 && exlist->op_first != exlist->op_last)
2352 break;
2353
2354 rv2cv = cUNOPx(exlist->op_last);
2355
2356 if (rv2cv->op_type != OP_RV2CV)
2357 break;
2358
2359 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2360 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2361 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2362
2363 o->op_private |= OPpASSIGN_CV_TO_GV;
2364 rv2gv->op_private |= OPpDONT_INIT_GV;
2365 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2366
2367 break;
2368 }
2369
2370 case OP_AASSIGN: {
2371 inplace_aassign(o);
2372 break;
2373 }
2374
2375 case OP_OR:
2376 case OP_AND:
2377 kid = cLOGOPo->op_first;
2378 if (kid->op_type == OP_NOT
2379 && (kid->op_flags & OPf_KIDS)) {
2380 if (o->op_type == OP_AND) {
2381 OpTYPE_set(o, OP_OR);
2382 } else {
2383 OpTYPE_set(o, OP_AND);
2384 }
2385 op_null(kid);
2386 }
2387 /* FALLTHROUGH */
2388
2389 case OP_DOR:
2390 case OP_COND_EXPR:
2391 case OP_ENTERGIVEN:
2392 case OP_ENTERWHEN:
2393 next_kid = OpSIBLING(cUNOPo->op_first);
2394 break;
2395
2396 case OP_NULL:
2397 if (o->op_flags & OPf_STACKED)
2398 break;
2399 /* FALLTHROUGH */
2400 case OP_NEXTSTATE:
2401 case OP_DBSTATE:
2402 case OP_ENTERTRY:
2403 case OP_ENTER:
2404 if (!(o->op_flags & OPf_KIDS))
2405 break;
2406 /* FALLTHROUGH */
2407 case OP_SCOPE:
2408 case OP_LEAVE:
2409 case OP_LEAVETRY:
2410 case OP_LEAVELOOP:
2411 case OP_LINESEQ:
2412 case OP_LEAVEGIVEN:
2413 case OP_LEAVEWHEN:
2414 kids:
2415 next_kid = cLISTOPo->op_first;
2416 break;
2417 case OP_LIST:
2418 /* If the first kid after pushmark is something that the padrange
2419 optimisation would reject, then null the list and the pushmark.
2420 */
2421 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2422 && ( !(kid = OpSIBLING(kid))
2423 || ( kid->op_type != OP_PADSV
2424 && kid->op_type != OP_PADAV
2425 && kid->op_type != OP_PADHV)
2426 || kid->op_private & ~OPpLVAL_INTRO
2427 || !(kid = OpSIBLING(kid))
2428 || ( kid->op_type != OP_PADSV
2429 && kid->op_type != OP_PADAV
2430 && kid->op_type != OP_PADHV)
2431 || kid->op_private & ~OPpLVAL_INTRO)
2432 ) {
2433 op_null(cUNOPo->op_first); /* NULL the pushmark */
2434 op_null(o); /* NULL the list */
2435 }
2436 goto kids;
2437 case OP_ENTEREVAL:
2438 scalarkids(o);
2439 break;
2440 case OP_SCALAR:
2441 scalar(o);
2442 break;
2443 }
2444
2445 if (useless_sv) {
2446 /* mortalise it, in case warnings are fatal. */
2447 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2448 "Useless use of %" SVf " in void context",
2449 SVfARG(sv_2mortal(useless_sv)));
2450 }
2451 else if (useless) {
2452 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2453 "Useless use of %s in void context",
2454 useless);
2455 }
2456
2457 get_next_op:
2458 /* if a kid hasn't been nominated to process, continue with the
2459 * next sibling, or if no siblings left, go back to the parent's
2460 * siblings and so on
2461 */
2462 while (!next_kid) {
2463 if (o == arg)
2464 return arg; /* at top; no parents/siblings to try */
2465 if (OpHAS_SIBLING(o))
2466 next_kid = o->op_sibparent;
2467 else
2468 o = o->op_sibparent; /*try parent's next sibling */
2469 }
2470 o = next_kid;
2471 }
2472 NOT_REACHED;
2473 }
2474
2475
2476 static OP *
S_listkids(pTHX_ OP * o)2477 S_listkids(pTHX_ OP *o)
2478 {
2479 if (o && o->op_flags & OPf_KIDS) {
2480 OP *kid;
2481 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2482 list(kid);
2483 }
2484 return o;
2485 }
2486
2487
2488 /* apply list context to the o subtree */
2489
2490 OP *
Perl_list(pTHX_ OP * o)2491 Perl_list(pTHX_ OP *o)
2492 {
2493 OP * top_op = o;
2494
2495 while (1) {
2496 OP *next_kid = NULL; /* what op (if any) to process next */
2497
2498 OP *kid;
2499
2500 /* assumes no premature commitment */
2501 if (!o || (o->op_flags & OPf_WANT)
2502 || (PL_parser && PL_parser->error_count)
2503 || o->op_type == OP_RETURN)
2504 {
2505 goto do_next;
2506 }
2507
2508 if ((o->op_private & OPpTARGET_MY)
2509 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2510 {
2511 goto do_next; /* As if inside SASSIGN */
2512 }
2513
2514 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2515
2516 switch (o->op_type) {
2517 case OP_REPEAT:
2518 if (o->op_private & OPpREPEAT_DOLIST
2519 && !(o->op_flags & OPf_STACKED))
2520 {
2521 list(cBINOPo->op_first);
2522 kid = cBINOPo->op_last;
2523 /* optimise away (.....) x 1 */
2524 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2525 && SvIVX(kSVOP_sv) == 1)
2526 {
2527 op_null(o); /* repeat */
2528 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2529 /* const (rhs): */
2530 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2531 }
2532 }
2533 break;
2534
2535 case OP_OR:
2536 case OP_AND:
2537 case OP_COND_EXPR:
2538 /* impose list context on everything except the condition */
2539 next_kid = OpSIBLING(cUNOPo->op_first);
2540 break;
2541
2542 default:
2543 if (!(o->op_flags & OPf_KIDS))
2544 break;
2545 /* possibly flatten 1..10 into a constant array */
2546 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2547 list(cBINOPo->op_first);
2548 gen_constant_list(o);
2549 goto do_next;
2550 }
2551 next_kid = cUNOPo->op_first; /* do all kids */
2552 break;
2553
2554 case OP_LIST:
2555 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2556 op_null(cUNOPo->op_first); /* NULL the pushmark */
2557 op_null(o); /* NULL the list */
2558 }
2559 if (o->op_flags & OPf_KIDS)
2560 next_kid = cUNOPo->op_first; /* do all kids */
2561 break;
2562
2563 /* the children of these ops are usually a list of statements,
2564 * except the leaves, whose first child is a corresponding enter
2565 */
2566 case OP_SCOPE:
2567 case OP_LINESEQ:
2568 kid = cLISTOPo->op_first;
2569 goto do_kids;
2570 case OP_LEAVE:
2571 case OP_LEAVETRY:
2572 kid = cLISTOPo->op_first;
2573 list(kid);
2574 kid = OpSIBLING(kid);
2575 do_kids:
2576 while (kid) {
2577 OP *sib = OpSIBLING(kid);
2578 /* Apply void context to all kids except the last, which
2579 * is list. E.g.
2580 * @a = do { void; void; list }
2581 * Except that 'when's are always list context, e.g.
2582 * @a = do { given(..) {
2583 * when (..) { list }
2584 * when (..) { list }
2585 * ...
2586 * }}
2587 */
2588 if (!sib) {
2589 /* tail call optimise calling list() on the last kid */
2590 next_kid = kid;
2591 goto do_next;
2592 }
2593 else if (kid->op_type == OP_LEAVEWHEN)
2594 list(kid);
2595 else
2596 scalarvoid(kid);
2597 kid = sib;
2598 }
2599 NOT_REACHED; /* NOTREACHED */
2600 break;
2601
2602 }
2603
2604 /* If next_kid is set, someone in the code above wanted us to process
2605 * that kid and all its remaining siblings. Otherwise, work our way
2606 * back up the tree */
2607 do_next:
2608 while (!next_kid) {
2609 if (o == top_op)
2610 return top_op; /* at top; no parents/siblings to try */
2611 if (OpHAS_SIBLING(o))
2612 next_kid = o->op_sibparent;
2613 else {
2614 o = o->op_sibparent; /*try parent's next sibling */
2615 switch (o->op_type) {
2616 case OP_SCOPE:
2617 case OP_LINESEQ:
2618 case OP_LIST:
2619 case OP_LEAVE:
2620 case OP_LEAVETRY:
2621 /* should really restore PL_curcop to its old value, but
2622 * setting it to PL_compiling is better than do nothing */
2623 PL_curcop = &PL_compiling;
2624 }
2625 }
2626
2627
2628 }
2629 o = next_kid;
2630 } /* while */
2631 }
2632
2633 /* apply void context to non-final ops of a sequence */
2634
2635 static OP *
S_voidnonfinal(pTHX_ OP * o)2636 S_voidnonfinal(pTHX_ OP *o)
2637 {
2638 if (o) {
2639 const OPCODE type = o->op_type;
2640
2641 if (type == OP_LINESEQ || type == OP_SCOPE ||
2642 type == OP_LEAVE || type == OP_LEAVETRY)
2643 {
2644 OP *kid = cLISTOPo->op_first, *sib;
2645 if(type == OP_LEAVE) {
2646 /* Don't put the OP_ENTER in void context */
2647 assert(kid->op_type == OP_ENTER);
2648 kid = OpSIBLING(kid);
2649 }
2650 for (; kid; kid = sib) {
2651 if ((sib = OpSIBLING(kid))
2652 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2653 || ( sib->op_targ != OP_NEXTSTATE
2654 && sib->op_targ != OP_DBSTATE )))
2655 {
2656 scalarvoid(kid);
2657 }
2658 }
2659 PL_curcop = &PL_compiling;
2660 }
2661 o->op_flags &= ~OPf_PARENS;
2662 if (PL_hints & HINT_BLOCK_SCOPE)
2663 o->op_flags |= OPf_PARENS;
2664 }
2665 else
2666 o = newOP(OP_STUB, 0);
2667 return o;
2668 }
2669
2670 STATIC OP *
S_modkids(pTHX_ OP * o,I32 type)2671 S_modkids(pTHX_ OP *o, I32 type)
2672 {
2673 if (o && o->op_flags & OPf_KIDS) {
2674 OP *kid;
2675 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2676 op_lvalue(kid, type);
2677 }
2678 return o;
2679 }
2680
2681
2682 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2683 * const fields. Also, convert CONST keys to HEK-in-SVs.
2684 * rop is the op that retrieves the hash;
2685 * key_op is the first key
2686 * real if false, only check (and possibly croak); don't update op
2687 */
2688
2689 void
Perl_check_hash_fields_and_hekify(pTHX_ UNOP * rop,SVOP * key_op,int real)2690 Perl_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2691 {
2692 PADNAME *lexname;
2693 GV **fields;
2694 bool check_fields;
2695
2696 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2697 if (rop) {
2698 if (rop->op_first->op_type == OP_PADSV)
2699 /* @$hash{qw(keys here)} */
2700 rop = cUNOPx(rop->op_first);
2701 else {
2702 /* @{$hash}{qw(keys here)} */
2703 if (rop->op_first->op_type == OP_SCOPE
2704 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2705 {
2706 rop = cUNOPx(cLISTOPx(rop->op_first)->op_last);
2707 }
2708 else
2709 rop = NULL;
2710 }
2711 }
2712
2713 lexname = NULL; /* just to silence compiler warnings */
2714 fields = NULL; /* just to silence compiler warnings */
2715
2716 check_fields =
2717 rop
2718 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2719 PadnameHasTYPE(lexname))
2720 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2721 && isGV(*fields) && GvHV(*fields);
2722
2723 for (; key_op; key_op = cSVOPx(OpSIBLING(key_op))) {
2724 SV **svp, *sv;
2725 if (key_op->op_type != OP_CONST)
2726 continue;
2727 svp = cSVOPx_svp(key_op);
2728
2729 /* make sure it's not a bareword under strict subs */
2730 if (key_op->op_private & OPpCONST_BARE &&
2731 key_op->op_private & OPpCONST_STRICT)
2732 {
2733 no_bareword_allowed((OP*)key_op);
2734 }
2735
2736 /* Make the CONST have a shared SV */
2737 if ( !SvIsCOW_shared_hash(sv = *svp)
2738 && SvTYPE(sv) < SVt_PVMG
2739 && SvOK(sv)
2740 && !SvROK(sv)
2741 && real)
2742 {
2743 SSize_t keylen;
2744 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2745 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2746 SvREFCNT_dec_NN(sv);
2747 *svp = nsv;
2748 }
2749
2750 if ( check_fields
2751 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2752 {
2753 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2754 "in variable %" PNf " of type %" HEKf,
2755 SVfARG(*svp), PNfARG(lexname),
2756 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2757 }
2758 }
2759 }
2760
2761
2762 /* do all the final processing on an optree (e.g. running the peephole
2763 * optimiser on it), then attach it to cv (if cv is non-null)
2764 */
2765
2766 static void
S_process_optree(pTHX_ CV * cv,OP * optree,OP * start)2767 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
2768 {
2769 OP **startp;
2770
2771 /* XXX for some reason, evals, require and main optrees are
2772 * never attached to their CV; instead they just hang off
2773 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
2774 * and get manually freed when appropriate */
2775 if (cv)
2776 startp = &CvSTART(cv);
2777 else
2778 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
2779
2780 *startp = start;
2781 optree->op_private |= OPpREFCOUNTED;
2782 OpREFCNT_set(optree, 1);
2783 optimize_optree(optree);
2784 CALL_PEEP(*startp);
2785 finalize_optree(optree);
2786 op_prune_chain_head(startp);
2787
2788 if (cv) {
2789 /* now that optimizer has done its work, adjust pad values */
2790 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
2791 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
2792 }
2793 }
2794
2795 #ifdef USE_ITHREADS
2796 /* Relocate sv to the pad for thread safety.
2797 * Despite being a "constant", the SV is written to,
2798 * for reference counts, sv_upgrade() etc. */
2799 void
Perl_op_relocate_sv(pTHX_ SV ** svp,PADOFFSET * targp)2800 Perl_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2801 {
2802 PADOFFSET ix;
2803 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2804 if (!*svp) return;
2805 ix = pad_alloc(OP_CONST, SVf_READONLY);
2806 SvREFCNT_dec(PAD_SVl(ix));
2807 PAD_SETSV(ix, *svp);
2808 /* XXX I don't know how this isn't readonly already. */
2809 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2810 *svp = NULL;
2811 *targp = ix;
2812 }
2813 #endif
2814
2815 static void
S_mark_padname_lvalue(pTHX_ PADNAME * pn)2816 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2817 {
2818 CV *cv = PL_compcv;
2819 PadnameLVALUE_on(pn);
2820 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2821 cv = CvOUTSIDE(cv);
2822 /* RT #127786: cv can be NULL due to an eval within the DB package
2823 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2824 * unless they contain an eval, but calling eval within DB
2825 * pretends the eval was done in the caller's scope.
2826 */
2827 if (!cv)
2828 break;
2829 assert(CvPADLIST(cv));
2830 pn =
2831 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2832 assert(PadnameLEN(pn));
2833 PadnameLVALUE_on(pn);
2834 }
2835 }
2836
2837 static bool
S_vivifies(const OPCODE type)2838 S_vivifies(const OPCODE type)
2839 {
2840 switch(type) {
2841 case OP_RV2AV: case OP_ASLICE:
2842 case OP_RV2HV: case OP_KVASLICE:
2843 case OP_RV2SV: case OP_HSLICE:
2844 case OP_AELEMFAST: case OP_KVHSLICE:
2845 case OP_HELEM:
2846 case OP_AELEM:
2847 return 1;
2848 }
2849 return 0;
2850 }
2851
2852
2853 /* apply lvalue reference (aliasing) context to the optree o.
2854 * E.g. in
2855 * \($x,$y) = (...)
2856 * o would be the list ($x,$y) and type would be OP_AASSIGN.
2857 * It may descend and apply this to children too, for example in
2858 * \( $cond ? $x, $y) = (...)
2859 */
2860
2861 static void
S_lvref(pTHX_ OP * o,I32 type)2862 S_lvref(pTHX_ OP *o, I32 type)
2863 {
2864 OP *kid;
2865 OP * top_op = o;
2866
2867 while (1) {
2868 switch (o->op_type) {
2869 case OP_COND_EXPR:
2870 o = OpSIBLING(cUNOPo->op_first);
2871 continue;
2872
2873 case OP_PUSHMARK:
2874 goto do_next;
2875
2876 case OP_RV2AV:
2877 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2878 o->op_flags |= OPf_STACKED;
2879 if (o->op_flags & OPf_PARENS) {
2880 if (o->op_private & OPpLVAL_INTRO) {
2881 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2882 "localized parenthesized array in list assignment"));
2883 goto do_next;
2884 }
2885 slurpy:
2886 OpTYPE_set(o, OP_LVAVREF);
2887 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2888 o->op_flags |= OPf_MOD|OPf_REF;
2889 goto do_next;
2890 }
2891 o->op_private |= OPpLVREF_AV;
2892 goto checkgv;
2893
2894 case OP_RV2CV:
2895 kid = cUNOPo->op_first;
2896 if (kid->op_type == OP_NULL)
2897 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2898 ->op_first;
2899 o->op_private = OPpLVREF_CV;
2900 if (kid->op_type == OP_GV)
2901 o->op_flags |= OPf_STACKED;
2902 else if (kid->op_type == OP_PADCV) {
2903 o->op_targ = kid->op_targ;
2904 kid->op_targ = 0;
2905 op_free(cUNOPo->op_first);
2906 cUNOPo->op_first = NULL;
2907 o->op_flags &=~ OPf_KIDS;
2908 }
2909 else goto badref;
2910 break;
2911
2912 case OP_RV2HV:
2913 if (o->op_flags & OPf_PARENS) {
2914 parenhash:
2915 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2916 "parenthesized hash in list assignment"));
2917 goto do_next;
2918 }
2919 o->op_private |= OPpLVREF_HV;
2920 /* FALLTHROUGH */
2921 case OP_RV2SV:
2922 checkgv:
2923 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2924 o->op_flags |= OPf_STACKED;
2925 break;
2926
2927 case OP_PADHV:
2928 if (o->op_flags & OPf_PARENS) goto parenhash;
2929 o->op_private |= OPpLVREF_HV;
2930 /* FALLTHROUGH */
2931 case OP_PADSV:
2932 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2933 break;
2934
2935 case OP_PADAV:
2936 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2937 if (o->op_flags & OPf_PARENS) goto slurpy;
2938 o->op_private |= OPpLVREF_AV;
2939 break;
2940
2941 case OP_AELEM:
2942 case OP_HELEM:
2943 o->op_private |= OPpLVREF_ELEM;
2944 o->op_flags |= OPf_STACKED;
2945 break;
2946
2947 case OP_ASLICE:
2948 case OP_HSLICE:
2949 OpTYPE_set(o, OP_LVREFSLICE);
2950 o->op_private &= OPpLVAL_INTRO;
2951 goto do_next;
2952
2953 case OP_NULL:
2954 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2955 goto badref;
2956 else if (!(o->op_flags & OPf_KIDS))
2957 goto do_next;
2958
2959 /* the code formerly only recursed into the first child of
2960 * a non ex-list OP_NULL. if we ever encounter such a null op with
2961 * more than one child, need to decide whether its ok to process
2962 * *all* its kids or not */
2963 assert(o->op_targ == OP_LIST
2964 || !(OpHAS_SIBLING(cBINOPo->op_first)));
2965 /* FALLTHROUGH */
2966 case OP_LIST:
2967 o = cLISTOPo->op_first;
2968 continue;
2969
2970 case OP_STUB:
2971 if (o->op_flags & OPf_PARENS)
2972 goto do_next;
2973 /* FALLTHROUGH */
2974 default:
2975 badref:
2976 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2977 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2978 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2979 ? "do block"
2980 : OP_DESC(o),
2981 PL_op_desc[type]));
2982 goto do_next;
2983 }
2984
2985 OpTYPE_set(o, OP_LVREF);
2986 o->op_private &=
2987 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2988 if (type == OP_ENTERLOOP)
2989 o->op_private |= OPpLVREF_ITER;
2990
2991 do_next:
2992 while (1) {
2993 if (o == top_op)
2994 return; /* at top; no parents/siblings to try */
2995 if (OpHAS_SIBLING(o)) {
2996 o = o->op_sibparent;
2997 break;
2998 }
2999 o = o->op_sibparent; /*try parent's next sibling */
3000 }
3001 } /* while */
3002 }
3003
3004
3005 PERL_STATIC_INLINE bool
S_potential_mod_type(I32 type)3006 S_potential_mod_type(I32 type)
3007 {
3008 /* Types that only potentially result in modification. */
3009 return type == OP_GREPSTART || type == OP_ENTERSUB
3010 || type == OP_REFGEN || type == OP_LEAVESUBLV;
3011 }
3012
3013
3014 /*
3015 =for apidoc op_lvalue
3016
3017 Propagate lvalue ("modifiable") context to an op and its children.
3018 C<type> represents the context type, roughly based on the type of op that
3019 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3020 because it has no op type of its own (it is signalled by a flag on
3021 the lvalue op).
3022
3023 This function detects things that can't be modified, such as C<$x+1>, and
3024 generates errors for them. For example, C<$x+1 = 2> would cause it to be
3025 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3026
3027 It also flags things that need to behave specially in an lvalue context,
3028 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3029
3030 =cut
3031
3032 Perl_op_lvalue_flags() is a non-API lower-level interface to
3033 op_lvalue(). The flags param has these bits:
3034 OP_LVALUE_NO_CROAK: return rather than croaking on error
3035
3036 */
3037
3038 OP *
Perl_op_lvalue_flags(pTHX_ OP * o,I32 type,U32 flags)3039 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3040 {
3041 OP *top_op = o;
3042
3043 if (!o || (PL_parser && PL_parser->error_count))
3044 return o;
3045
3046 while (1) {
3047 OP *kid;
3048 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3049 int localize = -1;
3050 OP *next_kid = NULL;
3051
3052 if ((o->op_private & OPpTARGET_MY)
3053 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3054 {
3055 goto do_next;
3056 }
3057
3058 /* elements of a list might be in void context because the list is
3059 in scalar context or because they are attribute sub calls */
3060 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
3061 goto do_next;
3062
3063 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3064
3065 switch (o->op_type) {
3066 case OP_UNDEF:
3067 if (type == OP_SASSIGN)
3068 goto nomod;
3069 PL_modcount++;
3070 goto do_next;
3071
3072 case OP_STUB:
3073 if ((o->op_flags & OPf_PARENS))
3074 break;
3075 goto nomod;
3076
3077 case OP_ENTERSUB:
3078 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3079 !(o->op_flags & OPf_STACKED)) {
3080 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3081 assert(cUNOPo->op_first->op_type == OP_NULL);
3082 op_null(cLISTOPx(cUNOPo->op_first)->op_first);/* disable pushmark */
3083 break;
3084 }
3085 else { /* lvalue subroutine call */
3086 o->op_private |= OPpLVAL_INTRO;
3087 PL_modcount = RETURN_UNLIMITED_NUMBER;
3088 if (S_potential_mod_type(type)) {
3089 o->op_private |= OPpENTERSUB_INARGS;
3090 break;
3091 }
3092 else { /* Compile-time error message: */
3093 OP *kid = cUNOPo->op_first;
3094 CV *cv;
3095 GV *gv;
3096 SV *namesv;
3097
3098 if (kid->op_type != OP_PUSHMARK) {
3099 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3100 Perl_croak(aTHX_
3101 "panic: unexpected lvalue entersub "
3102 "args: type/targ %ld:%" UVuf,
3103 (long)kid->op_type, (UV)kid->op_targ);
3104 kid = kLISTOP->op_first;
3105 }
3106 while (OpHAS_SIBLING(kid))
3107 kid = OpSIBLING(kid);
3108 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3109 break; /* Postpone until runtime */
3110 }
3111
3112 kid = kUNOP->op_first;
3113 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3114 kid = kUNOP->op_first;
3115 if (kid->op_type == OP_NULL)
3116 Perl_croak(aTHX_
3117 "panic: unexpected constant lvalue entersub "
3118 "entry via type/targ %ld:%" UVuf,
3119 (long)kid->op_type, (UV)kid->op_targ);
3120 if (kid->op_type != OP_GV) {
3121 break;
3122 }
3123
3124 gv = kGVOP_gv;
3125 cv = isGV(gv)
3126 ? GvCV(gv)
3127 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3128 ? MUTABLE_CV(SvRV(gv))
3129 : NULL;
3130 if (!cv)
3131 break;
3132 if (CvLVALUE(cv))
3133 break;
3134 if (flags & OP_LVALUE_NO_CROAK)
3135 return NULL;
3136
3137 namesv = cv_name(cv, NULL, 0);
3138 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
3139 "subroutine call of &%" SVf " in %s",
3140 SVfARG(namesv), PL_op_desc[type]),
3141 SvUTF8(namesv));
3142 goto do_next;
3143 }
3144 }
3145 /* FALLTHROUGH */
3146 default:
3147 nomod:
3148 if (flags & OP_LVALUE_NO_CROAK) return NULL;
3149 /* grep, foreach, subcalls, refgen */
3150 if (S_potential_mod_type(type))
3151 break;
3152 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
3153 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
3154 ? "do block"
3155 : OP_DESC(o)),
3156 type ? PL_op_desc[type] : "local"));
3157 goto do_next;
3158
3159 case OP_PREINC:
3160 case OP_PREDEC:
3161 case OP_POW:
3162 case OP_MULTIPLY:
3163 case OP_DIVIDE:
3164 case OP_MODULO:
3165 case OP_ADD:
3166 case OP_SUBTRACT:
3167 case OP_CONCAT:
3168 case OP_LEFT_SHIFT:
3169 case OP_RIGHT_SHIFT:
3170 case OP_BIT_AND:
3171 case OP_BIT_XOR:
3172 case OP_BIT_OR:
3173 case OP_I_MULTIPLY:
3174 case OP_I_DIVIDE:
3175 case OP_I_MODULO:
3176 case OP_I_ADD:
3177 case OP_I_SUBTRACT:
3178 if (!(o->op_flags & OPf_STACKED))
3179 goto nomod;
3180 PL_modcount++;
3181 break;
3182
3183 case OP_REPEAT:
3184 if (o->op_flags & OPf_STACKED) {
3185 PL_modcount++;
3186 break;
3187 }
3188 if (!(o->op_private & OPpREPEAT_DOLIST))
3189 goto nomod;
3190 else {
3191 const I32 mods = PL_modcount;
3192 /* we recurse rather than iterate here because we need to
3193 * calculate and use the delta applied to PL_modcount by the
3194 * first child. So in something like
3195 * ($x, ($y) x 3) = split;
3196 * split knows that 4 elements are wanted
3197 */
3198 modkids(cBINOPo->op_first, type);
3199 if (type != OP_AASSIGN)
3200 goto nomod;
3201 kid = cBINOPo->op_last;
3202 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3203 const IV iv = SvIV(kSVOP_sv);
3204 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3205 PL_modcount =
3206 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3207 }
3208 else
3209 PL_modcount = RETURN_UNLIMITED_NUMBER;
3210 }
3211 break;
3212
3213 case OP_COND_EXPR:
3214 localize = 1;
3215 next_kid = OpSIBLING(cUNOPo->op_first);
3216 break;
3217
3218 case OP_RV2AV:
3219 case OP_RV2HV:
3220 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3221 PL_modcount = RETURN_UNLIMITED_NUMBER;
3222 /* Treat \(@foo) like ordinary list, but still mark it as modi-
3223 fiable since some contexts need to know. */
3224 o->op_flags |= OPf_MOD;
3225 goto do_next;
3226 }
3227 /* FALLTHROUGH */
3228 case OP_RV2GV:
3229 if (scalar_mod_type(o, type))
3230 goto nomod;
3231 ref(cUNOPo->op_first, o->op_type);
3232 /* FALLTHROUGH */
3233 case OP_ASLICE:
3234 case OP_HSLICE:
3235 localize = 1;
3236 /* FALLTHROUGH */
3237 case OP_AASSIGN:
3238 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
3239 if (type == OP_LEAVESUBLV && (
3240 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3241 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3242 ))
3243 o->op_private |= OPpMAYBE_LVSUB;
3244 /* FALLTHROUGH */
3245 case OP_NEXTSTATE:
3246 case OP_DBSTATE:
3247 PL_modcount = RETURN_UNLIMITED_NUMBER;
3248 break;
3249
3250 case OP_KVHSLICE:
3251 case OP_KVASLICE:
3252 case OP_AKEYS:
3253 if (type == OP_LEAVESUBLV)
3254 o->op_private |= OPpMAYBE_LVSUB;
3255 goto nomod;
3256
3257 case OP_AVHVSWITCH:
3258 if (type == OP_LEAVESUBLV
3259 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
3260 o->op_private |= OPpMAYBE_LVSUB;
3261 goto nomod;
3262
3263 case OP_AV2ARYLEN:
3264 PL_hints |= HINT_BLOCK_SCOPE;
3265 if (type == OP_LEAVESUBLV)
3266 o->op_private |= OPpMAYBE_LVSUB;
3267 PL_modcount++;
3268 break;
3269
3270 case OP_RV2SV:
3271 ref(cUNOPo->op_first, o->op_type);
3272 localize = 1;
3273 /* FALLTHROUGH */
3274 case OP_GV:
3275 PL_hints |= HINT_BLOCK_SCOPE;
3276 /* FALLTHROUGH */
3277 case OP_SASSIGN:
3278 case OP_ANDASSIGN:
3279 case OP_ORASSIGN:
3280 case OP_DORASSIGN:
3281 PL_modcount++;
3282 break;
3283
3284 case OP_AELEMFAST:
3285 case OP_AELEMFAST_LEX:
3286 localize = -1;
3287 PL_modcount++;
3288 break;
3289
3290 case OP_PADAV:
3291 case OP_PADHV:
3292 PL_modcount = RETURN_UNLIMITED_NUMBER;
3293 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3294 {
3295 /* Treat \(@foo) like ordinary list, but still mark it as modi-
3296 fiable since some contexts need to know. */
3297 o->op_flags |= OPf_MOD;
3298 goto do_next;
3299 }
3300 if (scalar_mod_type(o, type))
3301 goto nomod;
3302 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3303 && type == OP_LEAVESUBLV)
3304 o->op_private |= OPpMAYBE_LVSUB;
3305 /* FALLTHROUGH */
3306 case OP_PADSV:
3307 PL_modcount++;
3308 if (!type) /* local() */
3309 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3310 PNfARG(PAD_COMPNAME(o->op_targ)));
3311 if (!(o->op_private & OPpLVAL_INTRO)
3312 || ( type != OP_SASSIGN && type != OP_AASSIGN
3313 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3314 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3315 break;
3316
3317 case OP_PUSHMARK:
3318 localize = 0;
3319 break;
3320
3321 case OP_KEYS:
3322 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3323 goto nomod;
3324 goto lvalue_func;
3325 case OP_SUBSTR:
3326 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3327 goto nomod;
3328 /* FALLTHROUGH */
3329 case OP_POS:
3330 case OP_VEC:
3331 lvalue_func:
3332 if (type == OP_LEAVESUBLV)
3333 o->op_private |= OPpMAYBE_LVSUB;
3334 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3335 /* we recurse rather than iterate here because the child
3336 * needs to be processed with a different 'type' parameter */
3337
3338 /* substr and vec */
3339 /* If this op is in merely potential (non-fatal) modifiable
3340 context, then apply OP_ENTERSUB context to
3341 the kid op (to avoid croaking). Other-
3342 wise pass this op’s own type so the correct op is mentioned
3343 in error messages. */
3344 op_lvalue(OpSIBLING(cBINOPo->op_first),
3345 S_potential_mod_type(type)
3346 ? (I32)OP_ENTERSUB
3347 : o->op_type);
3348 }
3349 break;
3350
3351 case OP_AELEM:
3352 case OP_HELEM:
3353 ref(cBINOPo->op_first, o->op_type);
3354 if (type == OP_ENTERSUB &&
3355 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3356 o->op_private |= OPpLVAL_DEFER;
3357 if (type == OP_LEAVESUBLV)
3358 o->op_private |= OPpMAYBE_LVSUB;
3359 localize = 1;
3360 PL_modcount++;
3361 break;
3362
3363 case OP_LEAVE:
3364 case OP_LEAVELOOP:
3365 o->op_private |= OPpLVALUE;
3366 /* FALLTHROUGH */
3367 case OP_SCOPE:
3368 case OP_ENTER:
3369 case OP_LINESEQ:
3370 localize = 0;
3371 if (o->op_flags & OPf_KIDS)
3372 next_kid = cLISTOPo->op_last;
3373 break;
3374
3375 case OP_NULL:
3376 localize = 0;
3377 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3378 goto nomod;
3379 else if (!(o->op_flags & OPf_KIDS))
3380 break;
3381
3382 if (o->op_targ != OP_LIST) {
3383 OP *sib = OpSIBLING(cLISTOPo->op_first);
3384 /* OP_TRANS and OP_TRANSR with argument have a weird optree
3385 * that looks like
3386 *
3387 * null
3388 * arg
3389 * trans
3390 *
3391 * compared with things like OP_MATCH which have the argument
3392 * as a child:
3393 *
3394 * match
3395 * arg
3396 *
3397 * so handle specially to correctly get "Can't modify" croaks etc
3398 */
3399
3400 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
3401 {
3402 /* this should trigger a "Can't modify transliteration" err */
3403 op_lvalue(sib, type);
3404 }
3405 next_kid = cBINOPo->op_first;
3406 /* we assume OP_NULLs which aren't ex-list have no more than 2
3407 * children. If this assumption is wrong, increase the scan
3408 * limit below */
3409 assert( !OpHAS_SIBLING(next_kid)
3410 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
3411 break;
3412 }
3413 /* FALLTHROUGH */
3414 case OP_LIST:
3415 localize = 0;
3416 next_kid = cLISTOPo->op_first;
3417 break;
3418
3419 case OP_COREARGS:
3420 goto do_next;
3421
3422 case OP_AND:
3423 case OP_OR:
3424 if (type == OP_LEAVESUBLV
3425 || !S_vivifies(cLOGOPo->op_first->op_type))
3426 next_kid = cLOGOPo->op_first;
3427 else if (type == OP_LEAVESUBLV
3428 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3429 next_kid = OpSIBLING(cLOGOPo->op_first);
3430 goto nomod;
3431
3432 case OP_SREFGEN:
3433 if (type == OP_NULL) { /* local */
3434 local_refgen:
3435 if (!FEATURE_MYREF_IS_ENABLED)
3436 Perl_croak(aTHX_ "The experimental declared_refs "
3437 "feature is not enabled");
3438 Perl_ck_warner_d(aTHX_
3439 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3440 "Declaring references is experimental");
3441 next_kid = cUNOPo->op_first;
3442 goto do_next;
3443 }
3444 if (type != OP_AASSIGN && type != OP_SASSIGN
3445 && type != OP_ENTERLOOP)
3446 goto nomod;
3447 /* Don’t bother applying lvalue context to the ex-list. */
3448 kid = cUNOPx(cUNOPo->op_first)->op_first;
3449 assert (!OpHAS_SIBLING(kid));
3450 goto kid_2lvref;
3451 case OP_REFGEN:
3452 if (type == OP_NULL) /* local */
3453 goto local_refgen;
3454 if (type != OP_AASSIGN) goto nomod;
3455 kid = cUNOPo->op_first;
3456 kid_2lvref:
3457 {
3458 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3459 S_lvref(aTHX_ kid, type);
3460 if (!PL_parser || PL_parser->error_count == ec) {
3461 if (!FEATURE_REFALIASING_IS_ENABLED)
3462 Perl_croak(aTHX_
3463 "Experimental aliasing via reference not enabled");
3464 Perl_ck_warner_d(aTHX_
3465 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3466 "Aliasing via reference is experimental");
3467 }
3468 }
3469 if (o->op_type == OP_REFGEN)
3470 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3471 op_null(o);
3472 goto do_next;
3473
3474 case OP_SPLIT:
3475 if ((o->op_private & OPpSPLIT_ASSIGN)) {
3476 /* This is actually @array = split. */
3477 PL_modcount = RETURN_UNLIMITED_NUMBER;
3478 break;
3479 }
3480 goto nomod;
3481
3482 case OP_SCALAR:
3483 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3484 goto nomod;
3485
3486 case OP_ANONCODE:
3487 /* If we were to set OPf_REF on this and it was constructed by XS
3488 * code as a child of an OP_REFGEN then we'd end up generating a
3489 * double-ref when executed. We don't want to do that, so don't
3490 * set flag here.
3491 * See also https://github.com/Perl/perl5/issues/20384
3492 */
3493
3494 // Perl always sets OPf_REF as of 5.37.5.
3495 //
3496 if (LIKELY(o->op_flags & OPf_REF)) goto nomod;
3497
3498 // If we got here, then our op came from an XS module that predates
3499 // 5.37.5’s change to the op tree, which we have to handle a bit
3500 // diffrently to preserve backward compatibility.
3501 //
3502 goto do_next;
3503 }
3504
3505 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3506 their argument is a filehandle; thus \stat(".") should not set
3507 it. AMS 20011102 */
3508 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
3509 goto do_next;
3510
3511 if (type != OP_LEAVESUBLV)
3512 o->op_flags |= OPf_MOD;
3513
3514 if (type == OP_AASSIGN || type == OP_SASSIGN)
3515 o->op_flags |= o->op_type == OP_ENTERSUB ? 0 : OPf_SPECIAL|OPf_REF;
3516 else if (!type) { /* local() */
3517 switch (localize) {
3518 case 1:
3519 o->op_private |= OPpLVAL_INTRO;
3520 o->op_flags &= ~OPf_SPECIAL;
3521 PL_hints |= HINT_BLOCK_SCOPE;
3522 break;
3523 case 0:
3524 break;
3525 case -1:
3526 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3527 "Useless localization of %s", OP_DESC(o));
3528 }
3529 }
3530 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3531 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3532 o->op_flags |= OPf_REF;
3533
3534 do_next:
3535 while (!next_kid) {
3536 if (o == top_op)
3537 return top_op; /* at top; no parents/siblings to try */
3538 if (OpHAS_SIBLING(o)) {
3539 next_kid = o->op_sibparent;
3540 if (!OpHAS_SIBLING(next_kid)) {
3541 /* a few node types don't recurse into their second child */
3542 OP *parent = next_kid->op_sibparent;
3543 I32 ptype = parent->op_type;
3544 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
3545 || ( (ptype == OP_AND || ptype == OP_OR)
3546 && (type != OP_LEAVESUBLV
3547 && S_vivifies(next_kid->op_type))
3548 )
3549 ) {
3550 /*try parent's next sibling */
3551 o = parent;
3552 next_kid = NULL;
3553 }
3554 }
3555 }
3556 else
3557 o = o->op_sibparent; /*try parent's next sibling */
3558
3559 }
3560 o = next_kid;
3561
3562 } /* while */
3563
3564 }
3565
3566
3567 STATIC bool
S_scalar_mod_type(const OP * o,I32 type)3568 S_scalar_mod_type(const OP *o, I32 type)
3569 {
3570 switch (type) {
3571 case OP_POS:
3572 case OP_SASSIGN:
3573 if (o && o->op_type == OP_RV2GV)
3574 return FALSE;
3575 /* FALLTHROUGH */
3576 case OP_PREINC:
3577 case OP_PREDEC:
3578 case OP_POSTINC:
3579 case OP_POSTDEC:
3580 case OP_I_PREINC:
3581 case OP_I_PREDEC:
3582 case OP_I_POSTINC:
3583 case OP_I_POSTDEC:
3584 case OP_POW:
3585 case OP_MULTIPLY:
3586 case OP_DIVIDE:
3587 case OP_MODULO:
3588 case OP_REPEAT:
3589 case OP_ADD:
3590 case OP_SUBTRACT:
3591 case OP_I_MULTIPLY:
3592 case OP_I_DIVIDE:
3593 case OP_I_MODULO:
3594 case OP_I_ADD:
3595 case OP_I_SUBTRACT:
3596 case OP_LEFT_SHIFT:
3597 case OP_RIGHT_SHIFT:
3598 case OP_BIT_AND:
3599 case OP_BIT_XOR:
3600 case OP_BIT_OR:
3601 case OP_NBIT_AND:
3602 case OP_NBIT_XOR:
3603 case OP_NBIT_OR:
3604 case OP_SBIT_AND:
3605 case OP_SBIT_XOR:
3606 case OP_SBIT_OR:
3607 case OP_CONCAT:
3608 case OP_SUBST:
3609 case OP_TRANS:
3610 case OP_TRANSR:
3611 case OP_READ:
3612 case OP_SYSREAD:
3613 case OP_RECV:
3614 case OP_ANDASSIGN:
3615 case OP_ORASSIGN:
3616 case OP_DORASSIGN:
3617 case OP_VEC:
3618 case OP_SUBSTR:
3619 return TRUE;
3620 default:
3621 return FALSE;
3622 }
3623 }
3624
3625 STATIC bool
S_is_handle_constructor(const OP * o,I32 numargs)3626 S_is_handle_constructor(const OP *o, I32 numargs)
3627 {
3628 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3629
3630 switch (o->op_type) {
3631 case OP_PIPE_OP:
3632 case OP_SOCKPAIR:
3633 if (numargs == 2)
3634 return TRUE;
3635 /* FALLTHROUGH */
3636 case OP_SYSOPEN:
3637 case OP_OPEN:
3638 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3639 case OP_SOCKET:
3640 case OP_OPEN_DIR:
3641 case OP_ACCEPT:
3642 if (numargs == 1)
3643 return TRUE;
3644 /* FALLTHROUGH */
3645 default:
3646 return FALSE;
3647 }
3648 }
3649
3650 static OP *
S_refkids(pTHX_ OP * o,I32 type)3651 S_refkids(pTHX_ OP *o, I32 type)
3652 {
3653 if (o && o->op_flags & OPf_KIDS) {
3654 OP *kid;
3655 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3656 ref(kid, type);
3657 }
3658 return o;
3659 }
3660
3661
3662 /* Apply reference (autovivification) context to the subtree at o.
3663 * For example in
3664 * push @{expression}, ....;
3665 * o will be the head of 'expression' and type will be OP_RV2AV.
3666 * It marks the op o (or a suitable child) as autovivifying, e.g. by
3667 * setting OPf_MOD.
3668 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
3669 * set_op_ref is true.
3670 *
3671 * Also calls scalar(o).
3672 */
3673
3674 OP *
Perl_doref(pTHX_ OP * o,I32 type,bool set_op_ref)3675 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3676 {
3677 OP * top_op = o;
3678
3679 PERL_ARGS_ASSERT_DOREF;
3680
3681 if (PL_parser && PL_parser->error_count)
3682 return o;
3683
3684 while (1) {
3685 switch (o->op_type) {
3686 case OP_ENTERSUB:
3687 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3688 !(o->op_flags & OPf_STACKED)) {
3689 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3690 assert(cUNOPo->op_first->op_type == OP_NULL);
3691 /* disable pushmark */
3692 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
3693 o->op_flags |= OPf_SPECIAL;
3694 }
3695 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3696 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3697 : type == OP_RV2HV ? OPpDEREF_HV
3698 : OPpDEREF_SV);
3699 o->op_flags |= OPf_MOD;
3700 }
3701
3702 break;
3703
3704 case OP_COND_EXPR:
3705 o = OpSIBLING(cUNOPo->op_first);
3706 continue;
3707
3708 case OP_RV2SV:
3709 if (type == OP_DEFINED)
3710 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3711 /* FALLTHROUGH */
3712 case OP_PADSV:
3713 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3714 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3715 : type == OP_RV2HV ? OPpDEREF_HV
3716 : OPpDEREF_SV);
3717 o->op_flags |= OPf_MOD;
3718 }
3719 if (o->op_flags & OPf_KIDS) {
3720 type = o->op_type;
3721 o = cUNOPo->op_first;
3722 continue;
3723 }
3724 break;
3725
3726 case OP_RV2AV:
3727 case OP_RV2HV:
3728 if (set_op_ref)
3729 o->op_flags |= OPf_REF;
3730 /* FALLTHROUGH */
3731 case OP_RV2GV:
3732 if (type == OP_DEFINED)
3733 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3734 type = o->op_type;
3735 o = cUNOPo->op_first;
3736 continue;
3737
3738 case OP_PADAV:
3739 case OP_PADHV:
3740 if (set_op_ref)
3741 o->op_flags |= OPf_REF;
3742 break;
3743
3744 case OP_SCALAR:
3745 case OP_NULL:
3746 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3747 break;
3748 o = cBINOPo->op_first;
3749 continue;
3750
3751 case OP_AELEM:
3752 case OP_HELEM:
3753 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3754 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3755 : type == OP_RV2HV ? OPpDEREF_HV
3756 : OPpDEREF_SV);
3757 o->op_flags |= OPf_MOD;
3758 }
3759 type = o->op_type;
3760 o = cBINOPo->op_first;
3761 continue;;
3762
3763 case OP_SCOPE:
3764 case OP_LEAVE:
3765 set_op_ref = FALSE;
3766 /* FALLTHROUGH */
3767 case OP_ENTER:
3768 case OP_LIST:
3769 if (!(o->op_flags & OPf_KIDS))
3770 break;
3771 o = cLISTOPo->op_last;
3772 continue;
3773
3774 default:
3775 break;
3776 } /* switch */
3777
3778 while (1) {
3779 if (o == top_op)
3780 return scalar(top_op); /* at top; no parents/siblings to try */
3781 if (OpHAS_SIBLING(o)) {
3782 o = o->op_sibparent;
3783 /* Normally skip all siblings and go straight to the parent;
3784 * the only op that requires two children to be processed
3785 * is OP_COND_EXPR */
3786 if (!OpHAS_SIBLING(o)
3787 && o->op_sibparent->op_type == OP_COND_EXPR)
3788 break;
3789 continue;
3790 }
3791 o = o->op_sibparent; /*try parent's next sibling */
3792 }
3793 } /* while */
3794 }
3795
3796
3797 STATIC OP *
S_dup_attrlist(pTHX_ OP * o)3798 S_dup_attrlist(pTHX_ OP *o)
3799 {
3800 OP *rop;
3801
3802 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3803
3804 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3805 * where the first kid is OP_PUSHMARK and the remaining ones
3806 * are OP_CONST. We need to push the OP_CONST values.
3807 */
3808 if (o->op_type == OP_CONST)
3809 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3810 else {
3811 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3812 rop = NULL;
3813 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3814 if (o->op_type == OP_CONST)
3815 rop = op_append_elem(OP_LIST, rop,
3816 newSVOP(OP_CONST, o->op_flags,
3817 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3818 }
3819 }
3820 return rop;
3821 }
3822
3823 STATIC void
S_apply_attrs(pTHX_ HV * stash,SV * target,OP * attrs)3824 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3825 {
3826 PERL_ARGS_ASSERT_APPLY_ATTRS;
3827 {
3828 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3829
3830 /* fake up C<use attributes $pkg,$rv,@attrs> */
3831
3832 #define ATTRSMODULE "attributes"
3833 #define ATTRSMODULE_PM "attributes.pm"
3834
3835 Perl_load_module(
3836 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3837 newSVpvs(ATTRSMODULE),
3838 NULL,
3839 op_prepend_elem(OP_LIST,
3840 newSVOP(OP_CONST, 0, stashsv),
3841 op_prepend_elem(OP_LIST,
3842 newSVOP(OP_CONST, 0,
3843 newRV(target)),
3844 dup_attrlist(attrs))));
3845 }
3846 }
3847
3848 STATIC void
S_apply_attrs_my(pTHX_ HV * stash,OP * target,OP * attrs,OP ** imopsp)3849 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3850 {
3851 OP *pack, *imop, *arg;
3852 SV *meth, *stashsv, **svp;
3853
3854 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3855
3856 if (!attrs)
3857 return;
3858
3859 assert(target->op_type == OP_PADSV ||
3860 target->op_type == OP_PADHV ||
3861 target->op_type == OP_PADAV);
3862
3863 /* Ensure that attributes.pm is loaded. */
3864 /* Don't force the C<use> if we don't need it. */
3865 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3866 if (svp && *svp != &PL_sv_undef)
3867 NOOP; /* already in %INC */
3868 else
3869 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3870 newSVpvs(ATTRSMODULE), NULL);
3871
3872 /* Need package name for method call. */
3873 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3874
3875 /* Build up the real arg-list. */
3876 stashsv = newSVhek(HvNAME_HEK(stash));
3877
3878 arg = newPADxVOP(OP_PADSV, 0, target->op_targ);
3879 arg = op_prepend_elem(OP_LIST,
3880 newSVOP(OP_CONST, 0, stashsv),
3881 op_prepend_elem(OP_LIST,
3882 newUNOP(OP_REFGEN, 0,
3883 arg),
3884 dup_attrlist(attrs)));
3885
3886 /* Fake up a method call to import */
3887 meth = newSVpvs_share("import");
3888 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_WANT_VOID,
3889 op_append_elem(OP_LIST,
3890 op_prepend_elem(OP_LIST, pack, arg),
3891 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3892
3893 /* Combine the ops. */
3894 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3895 }
3896
3897 /*
3898 =notfor apidoc apply_attrs_string
3899
3900 Attempts to apply a list of attributes specified by the C<attrstr> and
3901 C<len> arguments to the subroutine identified by the C<cv> argument which
3902 is expected to be associated with the package identified by the C<stashpv>
3903 argument (see L<attributes>). It gets this wrong, though, in that it
3904 does not correctly identify the boundaries of the individual attribute
3905 specifications within C<attrstr>. This is not really intended for the
3906 public API, but has to be listed here for systems such as AIX which
3907 need an explicit export list for symbols. (It's called from XS code
3908 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3909 to respect attribute syntax properly would be welcome.
3910
3911 =cut
3912 */
3913
3914 void
Perl_apply_attrs_string(pTHX_ const char * stashpv,CV * cv,const char * attrstr,STRLEN len)3915 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3916 const char *attrstr, STRLEN len)
3917 {
3918 OP *attrs = NULL;
3919
3920 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3921
3922 if (!len) {
3923 len = strlen(attrstr);
3924 }
3925
3926 while (len) {
3927 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3928 if (len) {
3929 const char * const sstr = attrstr;
3930 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3931 attrs = op_append_elem(OP_LIST, attrs,
3932 newSVOP(OP_CONST, 0,
3933 newSVpvn(sstr, attrstr-sstr)));
3934 }
3935 }
3936
3937 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3938 newSVpvs(ATTRSMODULE),
3939 NULL, op_prepend_elem(OP_LIST,
3940 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3941 op_prepend_elem(OP_LIST,
3942 newSVOP(OP_CONST, 0,
3943 newRV(MUTABLE_SV(cv))),
3944 attrs)));
3945 }
3946
3947 STATIC void
S_move_proto_attr(pTHX_ OP ** proto,OP ** attrs,const GV * name,bool curstash)3948 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
3949 bool curstash)
3950 {
3951 OP *new_proto = NULL;
3952 STRLEN pvlen;
3953 char *pv;
3954 OP *o;
3955
3956 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3957
3958 if (!*attrs)
3959 return;
3960
3961 o = *attrs;
3962 if (o->op_type == OP_CONST) {
3963 pv = SvPV(cSVOPo_sv, pvlen);
3964 if (memBEGINs(pv, pvlen, "prototype(")) {
3965 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3966 SV ** const tmpo = cSVOPx_svp(o);
3967 SvREFCNT_dec(cSVOPo_sv);
3968 *tmpo = tmpsv;
3969 new_proto = o;
3970 *attrs = NULL;
3971 }
3972 } else if (o->op_type == OP_LIST) {
3973 OP * lasto;
3974 assert(o->op_flags & OPf_KIDS);
3975 lasto = cLISTOPo->op_first;
3976 assert(lasto->op_type == OP_PUSHMARK);
3977 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3978 if (o->op_type == OP_CONST) {
3979 pv = SvPV(cSVOPo_sv, pvlen);
3980 if (memBEGINs(pv, pvlen, "prototype(")) {
3981 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3982 SV ** const tmpo = cSVOPx_svp(o);
3983 SvREFCNT_dec(cSVOPo_sv);
3984 *tmpo = tmpsv;
3985 if (new_proto && ckWARN(WARN_MISC)) {
3986 STRLEN new_len;
3987 const char * newp = SvPV(cSVOPo_sv, new_len);
3988 Perl_warner(aTHX_ packWARN(WARN_MISC),
3989 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3990 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3991 op_free(new_proto);
3992 }
3993 else if (new_proto)
3994 op_free(new_proto);
3995 new_proto = o;
3996 /* excise new_proto from the list */
3997 op_sibling_splice(*attrs, lasto, 1, NULL);
3998 o = lasto;
3999 continue;
4000 }
4001 }
4002 lasto = o;
4003 }
4004 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4005 would get pulled in with no real need */
4006 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4007 op_free(*attrs);
4008 *attrs = NULL;
4009 }
4010 }
4011
4012 if (new_proto) {
4013 SV *svname;
4014 if (isGV(name)) {
4015 svname = sv_newmortal();
4016 gv_efullname3(svname, name, NULL);
4017 }
4018 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4019 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4020 else
4021 svname = (SV *)name;
4022 if (ckWARN(WARN_ILLEGALPROTO))
4023 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4024 curstash);
4025 if (*proto && ckWARN(WARN_PROTOTYPE)) {
4026 STRLEN old_len, new_len;
4027 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4028 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4029
4030 if (curstash && svname == (SV *)name
4031 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4032 svname = sv_2mortal(newSVsv(PL_curstname));
4033 sv_catpvs(svname, "::");
4034 sv_catsv(svname, (SV *)name);
4035 }
4036
4037 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4038 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4039 " in %" SVf,
4040 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4041 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4042 SVfARG(svname));
4043 }
4044 if (*proto)
4045 op_free(*proto);
4046 *proto = new_proto;
4047 }
4048 }
4049
4050 static void
S_cant_declare(pTHX_ OP * o)4051 S_cant_declare(pTHX_ OP *o)
4052 {
4053 if (o->op_type == OP_NULL
4054 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4055 o = cUNOPo->op_first;
4056 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4057 o->op_type == OP_NULL
4058 && o->op_flags & OPf_SPECIAL
4059 ? "do block"
4060 : OP_DESC(o),
4061 PL_parser->in_my == KEY_our ? "our" :
4062 PL_parser->in_my == KEY_state ? "state" :
4063 "my"));
4064 }
4065
4066 STATIC OP *
S_my_kid(pTHX_ OP * o,OP * attrs,OP ** imopsp)4067 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4068 {
4069 I32 type;
4070 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4071
4072 PERL_ARGS_ASSERT_MY_KID;
4073
4074 if (!o || (PL_parser && PL_parser->error_count))
4075 return o;
4076
4077 type = o->op_type;
4078
4079 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4080 OP *kid;
4081 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4082 my_kid(kid, attrs, imopsp);
4083 return o;
4084 } else if (type == OP_UNDEF || type == OP_STUB) {
4085 return o;
4086 } else if (type == OP_RV2SV || /* "our" declaration */
4087 type == OP_RV2AV ||
4088 type == OP_RV2HV) {
4089 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4090 S_cant_declare(aTHX_ o);
4091 } else if (attrs) {
4092 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4093 assert(PL_parser);
4094 PL_parser->in_my = FALSE;
4095 PL_parser->in_my_stash = NULL;
4096 apply_attrs(GvSTASH(gv),
4097 (type == OP_RV2SV ? GvSVn(gv) :
4098 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4099 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4100 attrs);
4101 }
4102 o->op_private |= OPpOUR_INTRO;
4103 return o;
4104 }
4105 else if (type == OP_REFGEN || type == OP_SREFGEN) {
4106 if (!FEATURE_MYREF_IS_ENABLED)
4107 Perl_croak(aTHX_ "The experimental declared_refs "
4108 "feature is not enabled");
4109 Perl_ck_warner_d(aTHX_
4110 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4111 "Declaring references is experimental");
4112 /* Kid is a nulled OP_LIST, handled above. */
4113 my_kid(cUNOPo->op_first, attrs, imopsp);
4114 return o;
4115 }
4116 else if (type != OP_PADSV &&
4117 type != OP_PADAV &&
4118 type != OP_PADHV &&
4119 type != OP_PUSHMARK)
4120 {
4121 S_cant_declare(aTHX_ o);
4122 return o;
4123 }
4124 else if (attrs && type != OP_PUSHMARK) {
4125 HV *stash;
4126
4127 assert(PL_parser);
4128 PL_parser->in_my = FALSE;
4129 PL_parser->in_my_stash = NULL;
4130
4131 /* check for C<my Dog $spot> when deciding package */
4132 stash = PAD_COMPNAME_TYPE(o->op_targ);
4133 if (!stash)
4134 stash = PL_curstash;
4135 apply_attrs_my(stash, o, attrs, imopsp);
4136 }
4137 o->op_flags |= OPf_MOD;
4138 o->op_private |= OPpLVAL_INTRO;
4139 if (stately)
4140 o->op_private |= OPpPAD_STATE;
4141 return o;
4142 }
4143
4144 OP *
Perl_my_attrs(pTHX_ OP * o,OP * attrs)4145 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4146 {
4147 OP *rops;
4148 int maybe_scalar = 0;
4149
4150 PERL_ARGS_ASSERT_MY_ATTRS;
4151
4152 /* [perl #17376]: this appears to be premature, and results in code such as
4153 C< our(%x); > executing in list mode rather than void mode */
4154 #if 0
4155 if (o->op_flags & OPf_PARENS)
4156 list(o);
4157 else
4158 maybe_scalar = 1;
4159 #else
4160 maybe_scalar = 1;
4161 #endif
4162 if (attrs)
4163 SAVEFREEOP(attrs);
4164 rops = NULL;
4165 o = my_kid(o, attrs, &rops);
4166 if (rops) {
4167 if (maybe_scalar && o->op_type == OP_PADSV) {
4168 o = scalar(op_append_list(OP_LIST, rops, o));
4169 o->op_private |= OPpLVAL_INTRO;
4170 }
4171 else {
4172 /* The listop in rops might have a pushmark at the beginning,
4173 which will mess up list assignment. */
4174 LISTOP * const lrops = cLISTOPx(rops); /* for brevity */
4175 if (rops->op_type == OP_LIST &&
4176 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4177 {
4178 OP * const pushmark = lrops->op_first;
4179 /* excise pushmark */
4180 op_sibling_splice(rops, NULL, 1, NULL);
4181 op_free(pushmark);
4182 }
4183 o = op_append_list(OP_LIST, o, rops);
4184 }
4185 }
4186 PL_parser->in_my = FALSE;
4187 PL_parser->in_my_stash = NULL;
4188 return o;
4189 }
4190
4191 OP *
Perl_sawparens(pTHX_ OP * o)4192 Perl_sawparens(pTHX_ OP *o)
4193 {
4194 PERL_UNUSED_CONTEXT;
4195 if (o)
4196 o->op_flags |= OPf_PARENS;
4197 return o;
4198 }
4199
4200 OP *
Perl_bind_match(pTHX_ I32 type,OP * left,OP * right)4201 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4202 {
4203 OP *o;
4204 bool ismatchop = 0;
4205 const OPCODE ltype = left->op_type;
4206 const OPCODE rtype = right->op_type;
4207
4208 PERL_ARGS_ASSERT_BIND_MATCH;
4209
4210 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4211 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4212 {
4213 const char * const desc
4214 = PL_op_desc[(
4215 rtype == OP_SUBST || rtype == OP_TRANS
4216 || rtype == OP_TRANSR
4217 )
4218 ? (int)rtype : OP_MATCH];
4219 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4220 SV * const name = op_varname(left);
4221 if (name)
4222 Perl_warner(aTHX_ packWARN(WARN_MISC),
4223 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4224 desc, SVfARG(name), SVfARG(name));
4225 else {
4226 const char * const sample = (isary
4227 ? "@array" : "%hash");
4228 Perl_warner(aTHX_ packWARN(WARN_MISC),
4229 "Applying %s to %s will act on scalar(%s)",
4230 desc, sample, sample);
4231 }
4232 }
4233
4234 if (rtype == OP_CONST &&
4235 cSVOPx(right)->op_private & OPpCONST_BARE &&
4236 cSVOPx(right)->op_private & OPpCONST_STRICT)
4237 {
4238 no_bareword_allowed(right);
4239 }
4240
4241 /* !~ doesn't make sense with /r, so error on it for now */
4242 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
4243 type == OP_NOT)
4244 /* diag_listed_as: Using !~ with %s doesn't make sense */
4245 yyerror("Using !~ with s///r doesn't make sense");
4246 if (rtype == OP_TRANSR && type == OP_NOT)
4247 /* diag_listed_as: Using !~ with %s doesn't make sense */
4248 yyerror("Using !~ with tr///r doesn't make sense");
4249
4250 ismatchop = (rtype == OP_MATCH ||
4251 rtype == OP_SUBST ||
4252 rtype == OP_TRANS || rtype == OP_TRANSR)
4253 && !(right->op_flags & OPf_SPECIAL);
4254 if (ismatchop && right->op_private & OPpTARGET_MY) {
4255 right->op_targ = 0;
4256 right->op_private &= ~OPpTARGET_MY;
4257 }
4258 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
4259 if (left->op_type == OP_PADSV
4260 && !(left->op_private & OPpLVAL_INTRO))
4261 {
4262 right->op_targ = left->op_targ;
4263 op_free(left);
4264 o = right;
4265 }
4266 else {
4267 right->op_flags |= OPf_STACKED;
4268 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
4269 ! (rtype == OP_TRANS &&
4270 right->op_private & OPpTRANS_IDENTICAL) &&
4271 ! (rtype == OP_SUBST &&
4272 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
4273 left = op_lvalue(left, rtype);
4274 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
4275 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
4276 else
4277 o = op_prepend_elem(rtype, scalar(left), right);
4278 }
4279 if (type == OP_NOT)
4280 return newUNOP(OP_NOT, 0, scalar(o));
4281 return o;
4282 }
4283 else
4284 return bind_match(type, left,
4285 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
4286 }
4287
4288 OP *
Perl_invert(pTHX_ OP * o)4289 Perl_invert(pTHX_ OP *o)
4290 {
4291 if (!o)
4292 return NULL;
4293 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
4294 }
4295
4296 OP *
Perl_cmpchain_start(pTHX_ I32 type,OP * left,OP * right)4297 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
4298 {
4299 BINOP *bop;
4300 OP *op;
4301
4302 if (!left)
4303 left = newOP(OP_NULL, 0);
4304 if (!right)
4305 right = newOP(OP_NULL, 0);
4306 scalar(left);
4307 scalar(right);
4308 NewOp(0, bop, 1, BINOP);
4309 op = (OP*)bop;
4310 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
4311 OpTYPE_set(op, type);
4312 cBINOPx(op)->op_flags = OPf_KIDS;
4313 cBINOPx(op)->op_private = 2;
4314 cBINOPx(op)->op_first = left;
4315 cBINOPx(op)->op_last = right;
4316 OpMORESIB_set(left, right);
4317 OpLASTSIB_set(right, op);
4318 return op;
4319 }
4320
4321 OP *
Perl_cmpchain_extend(pTHX_ I32 type,OP * ch,OP * right)4322 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
4323 {
4324 BINOP *bop;
4325 OP *op;
4326
4327 PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
4328 if (!right)
4329 right = newOP(OP_NULL, 0);
4330 scalar(right);
4331 NewOp(0, bop, 1, BINOP);
4332 op = (OP*)bop;
4333 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
4334 OpTYPE_set(op, type);
4335 if (ch->op_type != OP_NULL) {
4336 UNOP *lch;
4337 OP *nch, *cleft, *cright;
4338 NewOp(0, lch, 1, UNOP);
4339 nch = (OP*)lch;
4340 OpTYPE_set(nch, OP_NULL);
4341 nch->op_flags = OPf_KIDS;
4342 cleft = cBINOPx(ch)->op_first;
4343 cright = cBINOPx(ch)->op_last;
4344 cBINOPx(ch)->op_first = NULL;
4345 cBINOPx(ch)->op_last = NULL;
4346 cBINOPx(ch)->op_private = 0;
4347 cBINOPx(ch)->op_flags = 0;
4348 cUNOPx(nch)->op_first = cright;
4349 OpMORESIB_set(cright, ch);
4350 OpMORESIB_set(ch, cleft);
4351 OpLASTSIB_set(cleft, nch);
4352 ch = nch;
4353 }
4354 OpMORESIB_set(right, op);
4355 OpMORESIB_set(op, cUNOPx(ch)->op_first);
4356 cUNOPx(ch)->op_first = right;
4357 return ch;
4358 }
4359
4360 OP *
Perl_cmpchain_finish(pTHX_ OP * ch)4361 Perl_cmpchain_finish(pTHX_ OP *ch)
4362 {
4363
4364 PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
4365 if (ch->op_type != OP_NULL) {
4366 OPCODE cmpoptype = ch->op_type;
4367 ch = CHECKOP(cmpoptype, ch);
4368 if(!ch->op_next && ch->op_type == cmpoptype)
4369 ch = fold_constants(op_integerize(op_std_init(ch)));
4370 return ch;
4371 } else {
4372 OP *condop = NULL;
4373 OP *rightarg = cUNOPx(ch)->op_first;
4374 cUNOPx(ch)->op_first = OpSIBLING(rightarg);
4375 OpLASTSIB_set(rightarg, NULL);
4376 while (1) {
4377 OP *cmpop = cUNOPx(ch)->op_first;
4378 OP *leftarg = OpSIBLING(cmpop);
4379 OPCODE cmpoptype = cmpop->op_type;
4380 OP *nextrightarg;
4381 bool is_last;
4382 is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
4383 OpLASTSIB_set(cmpop, NULL);
4384 OpLASTSIB_set(leftarg, NULL);
4385 if (is_last) {
4386 ch->op_flags = 0;
4387 op_free(ch);
4388 nextrightarg = NULL;
4389 } else {
4390 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
4391 leftarg = newOP(OP_NULL, 0);
4392 }
4393 cBINOPx(cmpop)->op_first = leftarg;
4394 cBINOPx(cmpop)->op_last = rightarg;
4395 OpMORESIB_set(leftarg, rightarg);
4396 OpLASTSIB_set(rightarg, cmpop);
4397 cmpop->op_flags = OPf_KIDS;
4398 cmpop->op_private = 2;
4399 cmpop = CHECKOP(cmpoptype, cmpop);
4400 if(!cmpop->op_next && cmpop->op_type == cmpoptype)
4401 cmpop = op_integerize(op_std_init(cmpop));
4402 condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
4403 cmpop;
4404 if (!nextrightarg)
4405 return condop;
4406 rightarg = nextrightarg;
4407 }
4408 }
4409 }
4410
4411 /*
4412 =for apidoc op_scope
4413
4414 Wraps up an op tree with some additional ops so that at runtime a dynamic
4415 scope will be created. The original ops run in the new dynamic scope,
4416 and then, provided that they exit normally, the scope will be unwound.
4417 The additional ops used to create and unwind the dynamic scope will
4418 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
4419 instead if the ops are simple enough to not need the full dynamic scope
4420 structure.
4421
4422 =cut
4423 */
4424
4425 OP *
Perl_op_scope(pTHX_ OP * o)4426 Perl_op_scope(pTHX_ OP *o)
4427 {
4428 if (o) {
4429 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4430 o = op_prepend_elem(OP_LINESEQ,
4431 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
4432 OpTYPE_set(o, OP_LEAVE);
4433 }
4434 else if (o->op_type == OP_LINESEQ) {
4435 OP *kid;
4436 OpTYPE_set(o, OP_SCOPE);
4437 kid = cLISTOPo->op_first;
4438 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4439 op_null(kid);
4440
4441 /* The following deals with things like 'do {1 for 1}' */
4442 kid = OpSIBLING(kid);
4443 if (kid &&
4444 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4445 op_null(kid);
4446 }
4447 }
4448 else
4449 o = newLISTOP(OP_SCOPE, 0, o, NULL);
4450 }
4451 return o;
4452 }
4453
4454 OP *
Perl_op_unscope(pTHX_ OP * o)4455 Perl_op_unscope(pTHX_ OP *o)
4456 {
4457 if (o && o->op_type == OP_LINESEQ) {
4458 OP *kid = cLISTOPo->op_first;
4459 for(; kid; kid = OpSIBLING(kid))
4460 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4461 op_null(kid);
4462 }
4463 return o;
4464 }
4465
4466 /*
4467 =for apidoc block_start
4468
4469 Handles compile-time scope entry.
4470 Arranges for hints to be restored on block
4471 exit and also handles pad sequence numbers to make lexical variables scope
4472 right. Returns a savestack index for use with C<block_end>.
4473
4474 =cut
4475 */
4476
4477 int
Perl_block_start(pTHX_ int full)4478 Perl_block_start(pTHX_ int full)
4479 {
4480 const int retval = PL_savestack_ix;
4481
4482 PL_compiling.cop_seq = PL_cop_seqmax;
4483 COP_SEQMAX_INC;
4484 pad_block_start(full);
4485 SAVEHINTS();
4486 PL_hints &= ~HINT_BLOCK_SCOPE;
4487 SAVECOMPILEWARNINGS();
4488 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4489 SAVEI32(PL_compiling.cop_seq);
4490 PL_compiling.cop_seq = 0;
4491
4492 CALL_BLOCK_HOOKS(bhk_start, full);
4493
4494 return retval;
4495 }
4496
4497 /*
4498 =for apidoc block_end
4499
4500 Handles compile-time scope exit. C<floor>
4501 is the savestack index returned by
4502 C<block_start>, and C<seq> is the body of the block. Returns the block,
4503 possibly modified.
4504
4505 =cut
4506 */
4507
4508 OP*
Perl_block_end(pTHX_ I32 floor,OP * seq)4509 Perl_block_end(pTHX_ I32 floor, OP *seq)
4510 {
4511 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4512 OP* retval = voidnonfinal(seq);
4513 OP *o;
4514
4515 /* XXX Is the null PL_parser check necessary here? */
4516 assert(PL_parser); /* Let’s find out under debugging builds. */
4517 if (PL_parser && PL_parser->parsed_sub) {
4518 o = newSTATEOP(0, NULL, NULL);
4519 op_null(o);
4520 retval = op_append_elem(OP_LINESEQ, retval, o);
4521 }
4522
4523 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4524
4525 LEAVE_SCOPE(floor);
4526 if (needblockscope)
4527 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4528 o = pad_leavemy();
4529
4530 if (o) {
4531 /* pad_leavemy has created a sequence of introcv ops for all my
4532 subs declared in the block. We have to replicate that list with
4533 clonecv ops, to deal with this situation:
4534
4535 sub {
4536 my sub s1;
4537 my sub s2;
4538 sub s1 { state sub foo { \&s2 } }
4539 }->()
4540
4541 Originally, I was going to have introcv clone the CV and turn
4542 off the stale flag. Since &s1 is declared before &s2, the
4543 introcv op for &s1 is executed (on sub entry) before the one for
4544 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
4545 cloned, since it is a state sub) closes over &s2 and expects
4546 to see it in its outer CV’s pad. If the introcv op clones &s1,
4547 then &s2 is still marked stale. Since &s1 is not active, and
4548 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4549 ble will not stay shared’ warning. Because it is the same stub
4550 that will be used when the introcv op for &s2 is executed, clos-
4551 ing over it is safe. Hence, we have to turn off the stale flag
4552 on all lexical subs in the block before we clone any of them.
4553 Hence, having introcv clone the sub cannot work. So we create a
4554 list of ops like this:
4555
4556 lineseq
4557 |
4558 +-- introcv
4559 |
4560 +-- introcv
4561 |
4562 +-- introcv
4563 |
4564 .
4565 .
4566 .
4567 |
4568 +-- clonecv
4569 |
4570 +-- clonecv
4571 |
4572 +-- clonecv
4573 |
4574 .
4575 .
4576 .
4577 */
4578 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4579 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4580 for (;; kid = OpSIBLING(kid)) {
4581 OP *newkid = newOP(OP_CLONECV, 0);
4582 newkid->op_targ = kid->op_targ;
4583 o = op_append_elem(OP_LINESEQ, o, newkid);
4584 if (kid == last) break;
4585 }
4586 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4587 }
4588
4589 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4590
4591 return retval;
4592 }
4593
4594 /*
4595 =for apidoc_section $scope
4596
4597 =for apidoc blockhook_register
4598
4599 Register a set of hooks to be called when the Perl lexical scope changes
4600 at compile time. See L<perlguts/"Compile-time scope hooks">.
4601
4602 =cut
4603 */
4604
4605 void
Perl_blockhook_register(pTHX_ BHK * hk)4606 Perl_blockhook_register(pTHX_ BHK *hk)
4607 {
4608 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4609
4610 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4611 }
4612
4613 void
Perl_newPROG(pTHX_ OP * o)4614 Perl_newPROG(pTHX_ OP *o)
4615 {
4616 OP *start;
4617
4618 PERL_ARGS_ASSERT_NEWPROG;
4619
4620 if (PL_in_eval) {
4621 PERL_CONTEXT *cx;
4622 I32 i;
4623 if (PL_eval_root)
4624 return;
4625 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4626 ((PL_in_eval & EVAL_KEEPERR)
4627 ? OPf_SPECIAL : 0), o);
4628
4629 cx = CX_CUR();
4630 assert(CxTYPE(cx) == CXt_EVAL);
4631
4632 if ((cx->blk_gimme & G_WANT) == G_VOID)
4633 scalarvoid(PL_eval_root);
4634 else if ((cx->blk_gimme & G_WANT) == G_LIST)
4635 list(PL_eval_root);
4636 else
4637 scalar(PL_eval_root);
4638
4639 start = op_linklist(PL_eval_root);
4640 PL_eval_root->op_next = 0;
4641 i = PL_savestack_ix;
4642 SAVEFREEOP(o);
4643 ENTER;
4644 S_process_optree(aTHX_ NULL, PL_eval_root, start);
4645 LEAVE;
4646 PL_savestack_ix = i;
4647 }
4648 else {
4649 if (o->op_type == OP_STUB) {
4650 /* This block is entered if nothing is compiled for the main
4651 program. This will be the case for an genuinely empty main
4652 program, or one which only has BEGIN blocks etc, so already
4653 run and freed.
4654
4655 Historically (5.000) the guard above was !o. However, commit
4656 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4657 c71fccf11fde0068, changed perly.y so that newPROG() is now
4658 called with the output of block_end(), which returns a new
4659 OP_STUB for the case of an empty optree. ByteLoader (and
4660 maybe other things) also take this path, because they set up
4661 PL_main_start and PL_main_root directly, without generating an
4662 optree.
4663
4664 If the parsing the main program aborts (due to parse errors,
4665 or due to BEGIN or similar calling exit), then newPROG()
4666 isn't even called, and hence this code path and its cleanups
4667 are skipped. This shouldn't make a make a difference:
4668 * a non-zero return from perl_parse is a failure, and
4669 perl_destruct() should be called immediately.
4670 * however, if exit(0) is called during the parse, then
4671 perl_parse() returns 0, and perl_run() is called. As
4672 PL_main_start will be NULL, perl_run() will return
4673 promptly, and the exit code will remain 0.
4674 */
4675
4676 PL_comppad_name = 0;
4677 PL_compcv = 0;
4678 S_op_destroy(aTHX_ o);
4679 return;
4680 }
4681 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4682 PL_curcop = &PL_compiling;
4683 start = LINKLIST(PL_main_root);
4684 PL_main_root->op_next = 0;
4685 S_process_optree(aTHX_ NULL, PL_main_root, start);
4686 if (!PL_parser->error_count)
4687 /* on error, leave CV slabbed so that ops left lying around
4688 * will eb cleaned up. Else unslab */
4689 cv_forget_slab(PL_compcv);
4690 PL_compcv = 0;
4691
4692 /* Register with debugger */
4693 if (PERLDB_INTER) {
4694 CV * const cv = get_cvs("DB::postponed", 0);
4695 if (cv) {
4696 dSP;
4697 PUSHMARK(SP);
4698 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4699 PUTBACK;
4700 call_sv(MUTABLE_SV(cv), G_DISCARD);
4701 }
4702 }
4703 }
4704 }
4705
4706 OP *
Perl_localize(pTHX_ OP * o,I32 lex)4707 Perl_localize(pTHX_ OP *o, I32 lex)
4708 {
4709 PERL_ARGS_ASSERT_LOCALIZE;
4710
4711 if (o->op_flags & OPf_PARENS)
4712 /* [perl #17376]: this appears to be premature, and results in code such as
4713 C< our(%x); > executing in list mode rather than void mode */
4714 #if 0
4715 list(o);
4716 #else
4717 NOOP;
4718 #endif
4719 else {
4720 if ( PL_parser->bufptr > PL_parser->oldbufptr
4721 && PL_parser->bufptr[-1] == ','
4722 && ckWARN(WARN_PARENTHESIS))
4723 {
4724 char *s = PL_parser->bufptr;
4725 bool sigil = FALSE;
4726
4727 /* some heuristics to detect a potential error */
4728 while (*s && (memCHRs(", \t\n", *s)))
4729 s++;
4730
4731 while (1) {
4732 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
4733 && *++s
4734 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4735 s++;
4736 sigil = TRUE;
4737 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4738 s++;
4739 while (*s && (memCHRs(", \t\n", *s)))
4740 s++;
4741 }
4742 else
4743 break;
4744 }
4745 if (sigil && (*s == ';' || *s == '=')) {
4746 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4747 "Parentheses missing around \"%s\" list",
4748 lex
4749 ? (PL_parser->in_my == KEY_our
4750 ? "our"
4751 : PL_parser->in_my == KEY_state
4752 ? "state"
4753 : "my")
4754 : "local");
4755 }
4756 }
4757 }
4758 if (lex)
4759 o = my(o);
4760 else
4761 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4762 PL_parser->in_my = FALSE;
4763 PL_parser->in_my_stash = NULL;
4764 return o;
4765 }
4766
4767 OP *
Perl_jmaybe(pTHX_ OP * o)4768 Perl_jmaybe(pTHX_ OP *o)
4769 {
4770 PERL_ARGS_ASSERT_JMAYBE;
4771
4772 if (o->op_type == OP_LIST) {
4773 if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
4774 OP * const o2
4775 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4776 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4777 }
4778 else {
4779 /* If the user disables this, then a warning might not be enough to alert
4780 them to a possible change of behaviour here, so throw an exception.
4781 */
4782 yyerror("Multidimensional hash lookup is disabled");
4783 }
4784 }
4785 return o;
4786 }
4787
4788 PERL_STATIC_INLINE OP *
S_op_std_init(pTHX_ OP * o)4789 S_op_std_init(pTHX_ OP *o)
4790 {
4791 I32 type = o->op_type;
4792
4793 PERL_ARGS_ASSERT_OP_STD_INIT;
4794
4795 if (PL_opargs[type] & OA_RETSCALAR)
4796 scalar(o);
4797 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4798 o->op_targ = pad_alloc(type, SVs_PADTMP);
4799
4800 return o;
4801 }
4802
4803 PERL_STATIC_INLINE OP *
S_op_integerize(pTHX_ OP * o)4804 S_op_integerize(pTHX_ OP *o)
4805 {
4806 I32 type = o->op_type;
4807
4808 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4809
4810 /* integerize op. */
4811 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4812 {
4813 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4814 }
4815
4816 if (type == OP_NEGATE)
4817 /* XXX might want a ck_negate() for this */
4818 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4819
4820 return o;
4821 }
4822
4823 /* This function exists solely to provide a scope to limit
4824 setjmp/longjmp() messing with auto variables. It cannot be inlined because
4825 it uses setjmp
4826 */
4827 STATIC int
S_fold_constants_eval(pTHX)4828 S_fold_constants_eval(pTHX) {
4829 int ret = 0;
4830 dJMPENV;
4831
4832 JMPENV_PUSH(ret);
4833
4834 if (ret == 0) {
4835 CALLRUNOPS(aTHX);
4836 }
4837
4838 JMPENV_POP;
4839
4840 return ret;
4841 }
4842
4843 static OP *
S_fold_constants(pTHX_ OP * const o)4844 S_fold_constants(pTHX_ OP *const o)
4845 {
4846 OP *curop;
4847 OP *newop;
4848 I32 type = o->op_type;
4849 bool is_stringify;
4850 SV *sv = NULL;
4851 int ret = 0;
4852 OP *old_next;
4853 SV * const oldwarnhook = PL_warnhook;
4854 SV * const olddiehook = PL_diehook;
4855 COP not_compiling;
4856 U8 oldwarn = PL_dowarn;
4857 I32 old_cxix;
4858
4859 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4860
4861 if (!(PL_opargs[type] & OA_FOLDCONST))
4862 goto nope;
4863
4864 switch (type) {
4865 case OP_UCFIRST:
4866 case OP_LCFIRST:
4867 case OP_UC:
4868 case OP_LC:
4869 case OP_FC:
4870 #ifdef USE_LOCALE_CTYPE
4871 if (IN_LC_COMPILETIME(LC_CTYPE))
4872 goto nope;
4873 #endif
4874 break;
4875 case OP_SLT:
4876 case OP_SGT:
4877 case OP_SLE:
4878 case OP_SGE:
4879 case OP_SCMP:
4880 #ifdef USE_LOCALE_COLLATE
4881 if (IN_LC_COMPILETIME(LC_COLLATE))
4882 goto nope;
4883 #endif
4884 break;
4885 case OP_SPRINTF:
4886 /* XXX what about the numeric ops? */
4887 #ifdef USE_LOCALE_NUMERIC
4888 if (IN_LC_COMPILETIME(LC_NUMERIC))
4889 goto nope;
4890 #endif
4891 break;
4892 case OP_PACK:
4893 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4894 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4895 goto nope;
4896 {
4897 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4898 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4899 {
4900 const char *s = SvPVX_const(sv);
4901 while (s < SvEND(sv)) {
4902 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4903 s++;
4904 }
4905 }
4906 }
4907 break;
4908 case OP_REPEAT:
4909 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4910 break;
4911 case OP_SREFGEN:
4912 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4913 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4914 goto nope;
4915 }
4916
4917 if (PL_parser && PL_parser->error_count)
4918 goto nope; /* Don't try to run w/ errors */
4919
4920 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4921 switch (curop->op_type) {
4922 case OP_CONST:
4923 if ( (curop->op_private & OPpCONST_BARE)
4924 && (curop->op_private & OPpCONST_STRICT)) {
4925 no_bareword_allowed(curop);
4926 goto nope;
4927 }
4928 /* FALLTHROUGH */
4929 case OP_LIST:
4930 case OP_SCALAR:
4931 case OP_NULL:
4932 case OP_PUSHMARK:
4933 /* Foldable; move to next op in list */
4934 break;
4935
4936 default:
4937 /* No other op types are considered foldable */
4938 goto nope;
4939 }
4940 }
4941
4942 curop = LINKLIST(o);
4943 old_next = o->op_next;
4944 o->op_next = 0;
4945 PL_op = curop;
4946
4947 old_cxix = cxstack_ix;
4948 create_eval_scope(NULL, G_FAKINGEVAL);
4949
4950 /* Verify that we don't need to save it: */
4951 assert(PL_curcop == &PL_compiling);
4952 StructCopy(&PL_compiling, ¬_compiling, COP);
4953 PL_curcop = ¬_compiling;
4954 /* The above ensures that we run with all the correct hints of the
4955 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4956 assert(IN_PERL_RUNTIME);
4957 PL_warnhook = PERL_WARNHOOK_FATAL;
4958 PL_diehook = NULL;
4959
4960 /* Effective $^W=1. */
4961 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4962 PL_dowarn |= G_WARN_ON;
4963
4964 ret = S_fold_constants_eval(aTHX);
4965
4966 switch (ret) {
4967 case 0:
4968 sv = *(PL_stack_sp--);
4969 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4970 pad_swipe(o->op_targ, FALSE);
4971 }
4972 else if (SvTEMP(sv)) { /* grab mortal temp? */
4973 SvREFCNT_inc_simple_void(sv);
4974 SvTEMP_off(sv);
4975 }
4976 else { assert(SvIMMORTAL(sv)); }
4977 break;
4978 case 3:
4979 /* Something tried to die. Abandon constant folding. */
4980 /* Pretend the error never happened. */
4981 CLEAR_ERRSV();
4982 o->op_next = old_next;
4983 break;
4984 default:
4985 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4986 PL_warnhook = oldwarnhook;
4987 PL_diehook = olddiehook;
4988 /* XXX note that this croak may fail as we've already blown away
4989 * the stack - eg any nested evals */
4990 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4991 }
4992 PL_dowarn = oldwarn;
4993 PL_warnhook = oldwarnhook;
4994 PL_diehook = olddiehook;
4995 PL_curcop = &PL_compiling;
4996
4997 /* if we croaked, depending on how we croaked the eval scope
4998 * may or may not have already been popped */
4999 if (cxstack_ix > old_cxix) {
5000 assert(cxstack_ix == old_cxix + 1);
5001 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5002 delete_eval_scope();
5003 }
5004 if (ret)
5005 goto nope;
5006
5007 /* OP_STRINGIFY and constant folding are used to implement qq.
5008 Here the constant folding is an implementation detail that we
5009 want to hide. If the stringify op is itself already marked
5010 folded, however, then it is actually a folded join. */
5011 is_stringify = type == OP_STRINGIFY && !o->op_folded;
5012 op_free(o);
5013 assert(sv);
5014 if (is_stringify)
5015 SvPADTMP_off(sv);
5016 else if (!SvIMMORTAL(sv)) {
5017 SvPADTMP_on(sv);
5018 SvREADONLY_on(sv);
5019 }
5020 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5021 if (!is_stringify) newop->op_folded = 1;
5022 return newop;
5023
5024 nope:
5025 return o;
5026 }
5027
5028 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
5029 * the constant value being an AV holding the flattened range.
5030 */
5031
5032 static void
S_gen_constant_list(pTHX_ OP * o)5033 S_gen_constant_list(pTHX_ OP *o)
5034 {
5035 OP *curop, *old_next;
5036 SV * const oldwarnhook = PL_warnhook;
5037 SV * const olddiehook = PL_diehook;
5038 COP *old_curcop;
5039 U8 oldwarn = PL_dowarn;
5040 SV **svp;
5041 AV *av;
5042 I32 old_cxix;
5043 COP not_compiling;
5044 int ret = 0;
5045 dJMPENV;
5046 bool op_was_null;
5047
5048 list(o);
5049 if (PL_parser && PL_parser->error_count)
5050 return; /* Don't attempt to run with errors */
5051
5052 curop = LINKLIST(o);
5053 old_next = o->op_next;
5054 o->op_next = 0;
5055 op_was_null = o->op_type == OP_NULL;
5056 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5057 o->op_type = OP_CUSTOM;
5058 CALL_PEEP(curop);
5059 if (op_was_null)
5060 o->op_type = OP_NULL;
5061 op_prune_chain_head(&curop);
5062 PL_op = curop;
5063
5064 old_cxix = cxstack_ix;
5065 create_eval_scope(NULL, G_FAKINGEVAL);
5066
5067 old_curcop = PL_curcop;
5068 StructCopy(old_curcop, ¬_compiling, COP);
5069 PL_curcop = ¬_compiling;
5070 /* The above ensures that we run with all the correct hints of the
5071 current COP, but that IN_PERL_RUNTIME is true. */
5072 assert(IN_PERL_RUNTIME);
5073 PL_warnhook = PERL_WARNHOOK_FATAL;
5074 PL_diehook = NULL;
5075 JMPENV_PUSH(ret);
5076
5077 /* Effective $^W=1. */
5078 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5079 PL_dowarn |= G_WARN_ON;
5080
5081 switch (ret) {
5082 case 0:
5083 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5084 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5085 #endif
5086 Perl_pp_pushmark(aTHX);
5087 CALLRUNOPS(aTHX);
5088 PL_op = curop;
5089 assert (!(curop->op_flags & OPf_SPECIAL));
5090 assert(curop->op_type == OP_RANGE);
5091 Perl_pp_anonlist(aTHX);
5092 break;
5093 case 3:
5094 CLEAR_ERRSV();
5095 o->op_next = old_next;
5096 break;
5097 default:
5098 JMPENV_POP;
5099 PL_warnhook = oldwarnhook;
5100 PL_diehook = olddiehook;
5101 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5102 ret);
5103 }
5104
5105 JMPENV_POP;
5106 PL_dowarn = oldwarn;
5107 PL_warnhook = oldwarnhook;
5108 PL_diehook = olddiehook;
5109 PL_curcop = old_curcop;
5110
5111 if (cxstack_ix > old_cxix) {
5112 assert(cxstack_ix == old_cxix + 1);
5113 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5114 delete_eval_scope();
5115 }
5116 if (ret)
5117 return;
5118
5119 OpTYPE_set(o, OP_RV2AV);
5120 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
5121 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
5122 o->op_opt = 0; /* needs to be revisited in rpeep() */
5123 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5124
5125 /* replace subtree with an OP_CONST */
5126 curop = cUNOPo->op_first;
5127 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5128 op_free(curop);
5129
5130 if (AvFILLp(av) != -1)
5131 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5132 {
5133 SvPADTMP_on(*svp);
5134 SvREADONLY_on(*svp);
5135 }
5136 LINKLIST(o);
5137 list(o);
5138 return;
5139 }
5140
5141 /*
5142 =for apidoc_section $optree_manipulation
5143 */
5144
5145 enum {
5146 FORBID_LOOPEX_DEFAULT = (1<<0),
5147 };
5148
walk_ops_find_labels(pTHX_ OP * o,HV * gotolabels)5149 static void walk_ops_find_labels(pTHX_ OP *o, HV *gotolabels)
5150 {
5151 switch(o->op_type) {
5152 case OP_NEXTSTATE:
5153 case OP_DBSTATE:
5154 {
5155 STRLEN label_len;
5156 U32 label_flags;
5157 const char *label_pv = CopLABEL_len_flags((COP *)o, &label_len, &label_flags);
5158 if(!label_pv)
5159 break;
5160
5161 SV *labelsv = newSVpvn_flags(label_pv, label_len, label_flags);
5162 SAVEFREESV(labelsv);
5163
5164 sv_inc(HeVAL(hv_fetch_ent(gotolabels, labelsv, TRUE, 0)));
5165 break;
5166 }
5167 }
5168
5169 if(!(o->op_flags & OPf_KIDS))
5170 return;
5171
5172 OP *kid = cUNOPo->op_first;
5173 while(kid) {
5174 walk_ops_find_labels(aTHX_ kid, gotolabels);
5175 kid = OpSIBLING(kid);
5176 }
5177 }
5178
walk_ops_forbid(pTHX_ OP * o,U32 flags,HV * permittedloops,HV * permittedgotos,const char * blockname)5179 static void walk_ops_forbid(pTHX_ OP *o, U32 flags, HV *permittedloops, HV *permittedgotos, const char *blockname)
5180 {
5181 bool is_loop = FALSE;
5182 SV *labelsv = NULL;
5183
5184 switch(o->op_type) {
5185 case OP_NEXTSTATE:
5186 case OP_DBSTATE:
5187 PL_curcop = (COP *)o;
5188 return;
5189
5190 case OP_RETURN:
5191 goto forbid;
5192
5193 case OP_GOTO:
5194 {
5195 /* OPf_STACKED means either dynamically computed label or `goto &sub` */
5196 if(o->op_flags & OPf_STACKED)
5197 goto forbid;
5198
5199 SV *target = newSVpvn_utf8(cPVOPo->op_pv, strlen(cPVOPo->op_pv),
5200 cPVOPo->op_private & OPpPV_IS_UTF8);
5201 SAVEFREESV(target);
5202
5203 if(hv_fetch_ent(permittedgotos, target, FALSE, 0))
5204 break;
5205
5206 goto forbid;
5207 }
5208
5209 case OP_NEXT:
5210 case OP_LAST:
5211 case OP_REDO:
5212 {
5213 /* OPf_SPECIAL means this is a default loopex */
5214 if(o->op_flags & OPf_SPECIAL) {
5215 if(flags & FORBID_LOOPEX_DEFAULT)
5216 goto forbid;
5217
5218 break;
5219 }
5220 /* OPf_STACKED means it's a dynamically computed label */
5221 if(o->op_flags & OPf_STACKED)
5222 goto forbid;
5223
5224 SV *target = newSVpv(cPVOPo->op_pv, strlen(cPVOPo->op_pv));
5225 if(cPVOPo->op_private & OPpPV_IS_UTF8)
5226 SvUTF8_on(target);
5227 SAVEFREESV(target);
5228
5229 if(hv_fetch_ent(permittedloops, target, FALSE, 0))
5230 break;
5231
5232 goto forbid;
5233 }
5234
5235 case OP_LEAVELOOP:
5236 {
5237 STRLEN label_len;
5238 U32 label_flags;
5239 const char *label_pv = CopLABEL_len_flags(PL_curcop, &label_len, &label_flags);
5240
5241 if(label_pv) {
5242 labelsv = newSVpvn(label_pv, label_len);
5243 if(label_flags & SVf_UTF8)
5244 SvUTF8_on(labelsv);
5245 SAVEFREESV(labelsv);
5246
5247 sv_inc(HeVAL(hv_fetch_ent(permittedloops, labelsv, TRUE, 0)));
5248 }
5249
5250 is_loop = TRUE;
5251 break;
5252 }
5253
5254 forbid:
5255 /* diag_listed_as: Can't "%s" out of a "defer" block */
5256 /* diag_listed_as: Can't "%s" out of a "finally" block */
5257 croak("Can't \"%s\" out of %s", PL_op_name[o->op_type], blockname);
5258
5259 default:
5260 break;
5261 }
5262
5263 if(!(o->op_flags & OPf_KIDS))
5264 return;
5265
5266 OP *kid = cUNOPo->op_first;
5267 while(kid) {
5268 walk_ops_forbid(aTHX_ kid, flags, permittedloops, permittedgotos, blockname);
5269 kid = OpSIBLING(kid);
5270
5271 if(is_loop) {
5272 /* Now in the body of the loop; we can permit loopex default */
5273 flags &= ~FORBID_LOOPEX_DEFAULT;
5274 }
5275 }
5276
5277 if(is_loop && labelsv) {
5278 HE *he = hv_fetch_ent(permittedloops, labelsv, FALSE, 0);
5279 if(SvIV(HeVAL(he)) > 1)
5280 sv_dec(HeVAL(he));
5281 else
5282 hv_delete_ent(permittedloops, labelsv, 0, 0);
5283 }
5284 }
5285
5286 /*
5287 =for apidoc forbid_outofblock_ops
5288
5289 Checks an optree that implements a block, to ensure there are no control-flow
5290 ops that attempt to leave the block. Any C<OP_RETURN> is forbidden, as is any
5291 C<OP_GOTO>. Loops are analysed, so any LOOPEX op (C<OP_NEXT>, C<OP_LAST> or
5292 C<OP_REDO>) that affects a loop that contains it within the block are
5293 permitted, but those that do not are forbidden.
5294
5295 If any of these forbidden constructions are detected, an exception is thrown
5296 by using the op name and the blockname argument to construct a suitable
5297 message.
5298
5299 This function alone is not sufficient to ensure the optree does not perform
5300 any of these forbidden activities during runtime, as it might call a different
5301 function that performs a non-local LOOPEX, or a string-eval() that performs a
5302 C<goto>, or various other things. It is intended purely as a compile-time
5303 check for those that could be detected statically. Additional runtime checks
5304 may be required depending on the circumstance it is used for.
5305
5306 Note currently that I<all> C<OP_GOTO> ops are forbidden, even in cases where
5307 they might otherwise be safe to execute. This may be permitted in a later
5308 version.
5309
5310 =cut
5311 */
5312
5313 void
Perl_forbid_outofblock_ops(pTHX_ OP * o,const char * blockname)5314 Perl_forbid_outofblock_ops(pTHX_ OP *o, const char *blockname)
5315 {
5316 PERL_ARGS_ASSERT_FORBID_OUTOFBLOCK_OPS;
5317
5318 ENTER;
5319 SAVEVPTR(PL_curcop);
5320
5321 HV *looplabels = newHV();
5322 SAVEFREESV((SV *)looplabels);
5323
5324 HV *gotolabels = newHV();
5325 SAVEFREESV((SV *)gotolabels);
5326
5327 walk_ops_find_labels(aTHX_ o, gotolabels);
5328
5329 walk_ops_forbid(aTHX_ o, FORBID_LOOPEX_DEFAULT, looplabels, gotolabels, blockname);
5330
5331 LEAVE;
5332 }
5333
5334 /* List constructors */
5335
5336 /*
5337 =for apidoc op_append_elem
5338
5339 Append an item to the list of ops contained directly within a list-type
5340 op, returning the lengthened list. C<first> is the list-type op,
5341 and C<last> is the op to append to the list. C<optype> specifies the
5342 intended opcode for the list. If C<first> is not already a list of the
5343 right type, it will be upgraded into one. If either C<first> or C<last>
5344 is null, the other is returned unchanged.
5345
5346 =cut
5347 */
5348
5349 OP *
Perl_op_append_elem(pTHX_ I32 type,OP * first,OP * last)5350 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5351 {
5352 if (!first)
5353 return last;
5354
5355 if (!last)
5356 return first;
5357
5358 if (first->op_type != (unsigned)type
5359 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5360 {
5361 return newLISTOP(type, 0, first, last);
5362 }
5363
5364 op_sibling_splice(first, cLISTOPx(first)->op_last, 0, last);
5365 first->op_flags |= OPf_KIDS;
5366 return first;
5367 }
5368
5369 /*
5370 =for apidoc op_append_list
5371
5372 Concatenate the lists of ops contained directly within two list-type ops,
5373 returning the combined list. C<first> and C<last> are the list-type ops
5374 to concatenate. C<optype> specifies the intended opcode for the list.
5375 If either C<first> or C<last> is not already a list of the right type,
5376 it will be upgraded into one. If either C<first> or C<last> is null,
5377 the other is returned unchanged.
5378
5379 =cut
5380 */
5381
5382 OP *
Perl_op_append_list(pTHX_ I32 type,OP * first,OP * last)5383 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5384 {
5385 if (!first)
5386 return last;
5387
5388 if (!last)
5389 return first;
5390
5391 if (first->op_type != (unsigned)type)
5392 return op_prepend_elem(type, first, last);
5393
5394 if (last->op_type != (unsigned)type)
5395 return op_append_elem(type, first, last);
5396
5397 OpMORESIB_set(cLISTOPx(first)->op_last, cLISTOPx(last)->op_first);
5398 cLISTOPx(first)->op_last = cLISTOPx(last)->op_last;
5399 OpLASTSIB_set(cLISTOPx(first)->op_last, first);
5400 first->op_flags |= (last->op_flags & OPf_KIDS);
5401
5402 S_op_destroy(aTHX_ last);
5403
5404 return first;
5405 }
5406
5407 /*
5408 =for apidoc op_prepend_elem
5409
5410 Prepend an item to the list of ops contained directly within a list-type
5411 op, returning the lengthened list. C<first> is the op to prepend to the
5412 list, and C<last> is the list-type op. C<optype> specifies the intended
5413 opcode for the list. If C<last> is not already a list of the right type,
5414 it will be upgraded into one. If either C<first> or C<last> is null,
5415 the other is returned unchanged.
5416
5417 =cut
5418 */
5419
5420 OP *
Perl_op_prepend_elem(pTHX_ I32 type,OP * first,OP * last)5421 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5422 {
5423 if (!first)
5424 return last;
5425
5426 if (!last)
5427 return first;
5428
5429 if (last->op_type == (unsigned)type) {
5430 if (type == OP_LIST) { /* already a PUSHMARK there */
5431 /* insert 'first' after pushmark */
5432 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5433 if (!(first->op_flags & OPf_PARENS))
5434 last->op_flags &= ~OPf_PARENS;
5435 }
5436 else
5437 op_sibling_splice(last, NULL, 0, first);
5438 last->op_flags |= OPf_KIDS;
5439 return last;
5440 }
5441
5442 return newLISTOP(type, 0, first, last);
5443 }
5444
5445 /*
5446 =for apidoc op_convert_list
5447
5448 Converts C<o> into a list op if it is not one already, and then converts it
5449 into the specified C<type>, calling its check function, allocating a target if
5450 it needs one, and folding constants.
5451
5452 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5453 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
5454 C<op_convert_list> to make it the right type.
5455
5456 =cut
5457 */
5458
5459 OP *
Perl_op_convert_list(pTHX_ I32 type,I32 flags,OP * o)5460 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5461 {
5462 if (type < 0) type = -type, flags |= OPf_SPECIAL;
5463 if (type == OP_RETURN) {
5464 if (FEATURE_MODULE_TRUE_IS_ENABLED)
5465 flags |= OPf_SPECIAL;
5466 }
5467 if (!o || o->op_type != OP_LIST)
5468 o = force_list(o, FALSE);
5469 else
5470 {
5471 o->op_flags &= ~OPf_WANT;
5472 o->op_private &= ~OPpLVAL_INTRO;
5473 }
5474
5475 if (!(PL_opargs[type] & OA_MARK))
5476 op_null(cLISTOPo->op_first);
5477 else {
5478 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5479 if (kid2 && kid2->op_type == OP_COREARGS) {
5480 op_null(cLISTOPo->op_first);
5481 kid2->op_private |= OPpCOREARGS_PUSHMARK;
5482 }
5483 }
5484
5485 if (type != OP_SPLIT)
5486 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5487 * ck_split() create a real PMOP and leave the op's type as listop
5488 * for now. Otherwise op_free() etc will crash.
5489 */
5490 OpTYPE_set(o, type);
5491
5492 o->op_flags |= flags;
5493 if (flags & OPf_FOLDED)
5494 o->op_folded = 1;
5495
5496 o = CHECKOP(type, o);
5497 if (o->op_type != (unsigned)type)
5498 return o;
5499
5500 return fold_constants(op_integerize(op_std_init(o)));
5501 }
5502
5503 /* Constructors */
5504
5505
5506 /*
5507 =for apidoc_section $optree_construction
5508
5509 =for apidoc newNULLLIST
5510
5511 Constructs, checks, and returns a new C<stub> op, which represents an
5512 empty list expression.
5513
5514 =cut
5515 */
5516
5517 OP *
Perl_newNULLLIST(pTHX)5518 Perl_newNULLLIST(pTHX)
5519 {
5520 return newOP(OP_STUB, 0);
5521 }
5522
5523 /* promote o and any siblings to be a list if its not already; i.e.
5524 *
5525 * o - A - B
5526 *
5527 * becomes
5528 *
5529 * list
5530 * |
5531 * pushmark - o - A - B
5532 *
5533 * If nullit it true, the list op is nulled.
5534 */
5535
5536 static OP *
S_force_list(pTHX_ OP * o,bool nullit)5537 S_force_list(pTHX_ OP *o, bool nullit)
5538 {
5539 if (!o || o->op_type != OP_LIST) {
5540 OP *rest = NULL;
5541 if (o) {
5542 /* manually detach any siblings then add them back later */
5543 rest = OpSIBLING(o);
5544 OpLASTSIB_set(o, NULL);
5545 }
5546 o = newLISTOP(OP_LIST, 0, o, NULL);
5547 if (rest)
5548 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5549 }
5550 if (nullit)
5551 op_null(o);
5552 return o;
5553 }
5554
5555 /*
5556 =for apidoc op_force_list
5557
5558 Promotes o and any siblings to be an C<OP_LIST> if it is not already. If
5559 a new C<OP_LIST> op was created, its first child will be C<OP_PUSHMARK>.
5560 The returned node itself will be nulled, leaving only its children.
5561
5562 This is often what you want to do before putting the optree into list
5563 context; as
5564
5565 o = op_contextualize(op_force_list(o), G_LIST);
5566
5567 =cut
5568 */
5569
5570 OP *
Perl_op_force_list(pTHX_ OP * o)5571 Perl_op_force_list(pTHX_ OP *o)
5572 {
5573 return force_list(o, TRUE);
5574 }
5575
5576 /*
5577 =for apidoc newLISTOP
5578
5579 Constructs, checks, and returns an op of any list type. C<type> is
5580 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
5581 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
5582 supply up to two ops to be direct children of the list op; they are
5583 consumed by this function and become part of the constructed op tree.
5584
5585 For most list operators, the check function expects all the kid ops to be
5586 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
5587 appropriate. What you want to do in that case is create an op of type
5588 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
5589 See L</op_convert_list> for more information.
5590
5591 =cut
5592 */
5593
5594 OP *
Perl_newLISTOP(pTHX_ I32 type,I32 flags,OP * first,OP * last)5595 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5596 {
5597 LISTOP *listop;
5598 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
5599 * pushmark is banned. So do it now while existing ops are in a
5600 * consistent state, in case they suddenly get freed */
5601 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
5602
5603 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
5604 || type == OP_CUSTOM);
5605
5606 NewOp(1101, listop, 1, LISTOP);
5607 OpTYPE_set(listop, type);
5608 if (first || last)
5609 flags |= OPf_KIDS;
5610 listop->op_flags = (U8)flags;
5611
5612 if (!last && first)
5613 last = first;
5614 else if (!first && last)
5615 first = last;
5616 else if (first)
5617 OpMORESIB_set(first, last);
5618 listop->op_first = first;
5619 listop->op_last = last;
5620
5621 if (pushop) {
5622 OpMORESIB_set(pushop, first);
5623 listop->op_first = pushop;
5624 listop->op_flags |= OPf_KIDS;
5625 if (!last)
5626 listop->op_last = pushop;
5627 }
5628 if (listop->op_last)
5629 OpLASTSIB_set(listop->op_last, (OP*)listop);
5630
5631 return CHECKOP(type, listop);
5632 }
5633
5634 /*
5635 =for apidoc newOP
5636
5637 Constructs, checks, and returns an op of any base type (any type that
5638 has no extra fields). C<type> is the opcode. C<flags> gives the
5639 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
5640 of C<op_private>.
5641
5642 =cut
5643 */
5644
5645 OP *
Perl_newOP(pTHX_ I32 type,I32 flags)5646 Perl_newOP(pTHX_ I32 type, I32 flags)
5647 {
5648 OP *o;
5649
5650 if (type == -OP_ENTEREVAL) {
5651 type = OP_ENTEREVAL;
5652 flags |= OPpEVAL_BYTES<<8;
5653 }
5654
5655 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
5656 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5657 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5658 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5659
5660 NewOp(1101, o, 1, OP);
5661 OpTYPE_set(o, type);
5662 o->op_flags = (U8)flags;
5663
5664 o->op_next = o;
5665 o->op_private = (U8)(0 | (flags >> 8));
5666 if (PL_opargs[type] & OA_RETSCALAR)
5667 scalar(o);
5668 if (PL_opargs[type] & OA_TARGET)
5669 o->op_targ = pad_alloc(type, SVs_PADTMP);
5670 return CHECKOP(type, o);
5671 }
5672
5673 /*
5674 =for apidoc newUNOP
5675
5676 Constructs, checks, and returns an op of any unary type. C<type> is
5677 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
5678 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
5679 bits, the eight bits of C<op_private>, except that the bit with value 1
5680 is automatically set. C<first> supplies an optional op to be the direct
5681 child of the unary op; it is consumed by this function and become part
5682 of the constructed op tree.
5683
5684 =for apidoc Amnh||OPf_KIDS
5685
5686 =cut
5687 */
5688
5689 OP *
Perl_newUNOP(pTHX_ I32 type,I32 flags,OP * first)5690 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
5691 {
5692 UNOP *unop;
5693
5694 if (type == -OP_ENTEREVAL) {
5695 type = OP_ENTEREVAL;
5696 flags |= OPpEVAL_BYTES<<8;
5697 }
5698
5699 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
5700 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5701 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5702 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
5703 || type == OP_SASSIGN
5704 || type == OP_ENTERTRY
5705 || type == OP_ENTERTRYCATCH
5706 || type == OP_CUSTOM
5707 || type == OP_NULL );
5708
5709 if (!first)
5710 first = newOP(OP_STUB, 0);
5711 if (PL_opargs[type] & OA_MARK)
5712 first = op_force_list(first);
5713
5714 NewOp(1101, unop, 1, UNOP);
5715 OpTYPE_set(unop, type);
5716 unop->op_first = first;
5717 unop->op_flags = (U8)(flags | OPf_KIDS);
5718 unop->op_private = (U8)(1 | (flags >> 8));
5719
5720 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
5721 OpLASTSIB_set(first, (OP*)unop);
5722
5723 unop = (UNOP*) CHECKOP(type, unop);
5724 if (unop->op_next)
5725 return (OP*)unop;
5726
5727 return fold_constants(op_integerize(op_std_init((OP *) unop)));
5728 }
5729
5730 /*
5731 =for apidoc newUNOP_AUX
5732
5733 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
5734 initialised to C<aux>
5735
5736 =cut
5737 */
5738
5739 OP *
Perl_newUNOP_AUX(pTHX_ I32 type,I32 flags,OP * first,UNOP_AUX_item * aux)5740 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5741 {
5742 UNOP_AUX *unop;
5743
5744 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5745 || type == OP_CUSTOM);
5746
5747 NewOp(1101, unop, 1, UNOP_AUX);
5748 unop->op_type = (OPCODE)type;
5749 unop->op_ppaddr = PL_ppaddr[type];
5750 unop->op_first = first;
5751 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5752 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5753 unop->op_aux = aux;
5754
5755 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5756 OpLASTSIB_set(first, (OP*)unop);
5757
5758 unop = (UNOP_AUX*) CHECKOP(type, unop);
5759
5760 return op_std_init((OP *) unop);
5761 }
5762
5763 /*
5764 =for apidoc newMETHOP
5765
5766 Constructs, checks, and returns an op of method type with a method name
5767 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
5768 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5769 and, shifted up eight bits, the eight bits of C<op_private>, except that
5770 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
5771 op which evaluates method name; it is consumed by this function and
5772 become part of the constructed op tree.
5773 Supported optypes: C<OP_METHOD>.
5774
5775 =cut
5776 */
5777
5778 static OP*
S_newMETHOP_internal(pTHX_ I32 type,I32 flags,OP * dynamic_meth,SV * const_meth)5779 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5780 METHOP *methop;
5781
5782 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5783 || type == OP_CUSTOM);
5784
5785 NewOp(1101, methop, 1, METHOP);
5786 if (dynamic_meth) {
5787 if (PL_opargs[type] & OA_MARK) dynamic_meth = op_force_list(dynamic_meth);
5788 methop->op_flags = (U8)(flags | OPf_KIDS);
5789 methop->op_u.op_first = dynamic_meth;
5790 methop->op_private = (U8)(1 | (flags >> 8));
5791
5792 if (!OpHAS_SIBLING(dynamic_meth))
5793 OpLASTSIB_set(dynamic_meth, (OP*)methop);
5794 }
5795 else {
5796 assert(const_meth);
5797 methop->op_flags = (U8)(flags & ~OPf_KIDS);
5798 methop->op_u.op_meth_sv = const_meth;
5799 methop->op_private = (U8)(0 | (flags >> 8));
5800 methop->op_next = (OP*)methop;
5801 }
5802
5803 #ifdef USE_ITHREADS
5804 methop->op_rclass_targ = 0;
5805 #else
5806 methop->op_rclass_sv = NULL;
5807 #endif
5808
5809 OpTYPE_set(methop, type);
5810 return CHECKOP(type, methop);
5811 }
5812
5813 OP *
Perl_newMETHOP(pTHX_ I32 type,I32 flags,OP * dynamic_meth)5814 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5815 PERL_ARGS_ASSERT_NEWMETHOP;
5816 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5817 }
5818
5819 /*
5820 =for apidoc newMETHOP_named
5821
5822 Constructs, checks, and returns an op of method type with a constant
5823 method name. C<type> is the opcode. C<flags> gives the eight bits of
5824 C<op_flags>, and, shifted up eight bits, the eight bits of
5825 C<op_private>. C<const_meth> supplies a constant method name;
5826 it must be a shared COW string.
5827 Supported optypes: C<OP_METHOD_NAMED>.
5828
5829 =cut
5830 */
5831
5832 OP *
Perl_newMETHOP_named(pTHX_ I32 type,I32 flags,SV * const_meth)5833 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5834 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5835 return newMETHOP_internal(type, flags, NULL, const_meth);
5836 }
5837
5838 /*
5839 =for apidoc newBINOP
5840
5841 Constructs, checks, and returns an op of any binary type. C<type>
5842 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
5843 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5844 the eight bits of C<op_private>, except that the bit with value 1 or
5845 2 is automatically set as required. C<first> and C<last> supply up to
5846 two ops to be the direct children of the binary op; they are consumed
5847 by this function and become part of the constructed op tree.
5848
5849 =cut
5850 */
5851
5852 OP *
Perl_newBINOP(pTHX_ I32 type,I32 flags,OP * first,OP * last)5853 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5854 {
5855 BINOP *binop;
5856
5857 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5858 || type == OP_NULL || type == OP_CUSTOM);
5859
5860 NewOp(1101, binop, 1, BINOP);
5861
5862 if (!first)
5863 first = newOP(OP_NULL, 0);
5864
5865 OpTYPE_set(binop, type);
5866 binop->op_first = first;
5867 binop->op_flags = (U8)(flags | OPf_KIDS);
5868 if (!last) {
5869 last = first;
5870 binop->op_private = (U8)(1 | (flags >> 8));
5871 }
5872 else {
5873 binop->op_private = (U8)(2 | (flags >> 8));
5874 OpMORESIB_set(first, last);
5875 }
5876
5877 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5878 OpLASTSIB_set(last, (OP*)binop);
5879
5880 binop->op_last = OpSIBLING(binop->op_first);
5881 if (binop->op_last)
5882 OpLASTSIB_set(binop->op_last, (OP*)binop);
5883
5884 binop = (BINOP*) CHECKOP(type, binop);
5885 if (binop->op_next || binop->op_type != (OPCODE)type)
5886 return (OP*)binop;
5887
5888 return fold_constants(op_integerize(op_std_init((OP *)binop)));
5889 }
5890
5891 void
Perl_invmap_dump(pTHX_ SV * invlist,UV * map)5892 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
5893 {
5894 const char indent[] = " ";
5895
5896 UV len = _invlist_len(invlist);
5897 UV * array = invlist_array(invlist);
5898 UV i;
5899
5900 PERL_ARGS_ASSERT_INVMAP_DUMP;
5901
5902 for (i = 0; i < len; i++) {
5903 UV start = array[i];
5904 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
5905
5906 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
5907 if (end == IV_MAX) {
5908 PerlIO_printf(Perl_debug_log, " .. INFTY");
5909 }
5910 else if (end != start) {
5911 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
5912 }
5913 else {
5914 PerlIO_printf(Perl_debug_log, " ");
5915 }
5916
5917 PerlIO_printf(Perl_debug_log, "\t");
5918
5919 if (map[i] == TR_UNLISTED) {
5920 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
5921 }
5922 else if (map[i] == TR_SPECIAL_HANDLING) {
5923 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
5924 }
5925 else {
5926 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
5927 }
5928 }
5929 }
5930
5931 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
5932 * containing the search and replacement strings, assemble into
5933 * a translation table attached as o->op_pv.
5934 * Free expr and repl.
5935 * It expects the toker to have already set the
5936 * OPpTRANS_COMPLEMENT
5937 * OPpTRANS_SQUASH
5938 * OPpTRANS_DELETE
5939 * flags as appropriate; this function may add
5940 * OPpTRANS_USE_SVOP
5941 * OPpTRANS_CAN_FORCE_UTF8
5942 * OPpTRANS_IDENTICAL
5943 * OPpTRANS_GROWS
5944 * flags
5945 */
5946
5947 static OP *
S_pmtrans(pTHX_ OP * o,OP * expr,OP * repl)5948 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5949 {
5950 /* This function compiles a tr///, from data gathered from toke.c, into a
5951 * form suitable for use by do_trans() in doop.c at runtime.
5952 *
5953 * It first normalizes the data, while discarding extraneous inputs; then
5954 * writes out the compiled data. The normalization allows for complete
5955 * analysis, and avoids some false negatives and positives earlier versions
5956 * of this code had.
5957 *
5958 * The normalization form is an inversion map (described below in detail).
5959 * This is essentially the compiled form for tr///'s that require UTF-8,
5960 * and its easy to use it to write the 257-byte table for tr///'s that
5961 * don't need UTF-8. That table is identical to what's been in use for
5962 * many perl versions, except that it doesn't handle some edge cases that
5963 * it used to, involving code points above 255. The UTF-8 form now handles
5964 * these. (This could be changed with extra coding should it shown to be
5965 * desirable.)
5966 *
5967 * If the complement (/c) option is specified, the lhs string (tstr) is
5968 * parsed into an inversion list. Complementing these is trivial. Then a
5969 * complemented tstr is built from that, and used thenceforth. This hides
5970 * the fact that it was complemented from almost all successive code.
5971 *
5972 * One of the important characteristics to know about the input is whether
5973 * the transliteration may be done in place, or does a temporary need to be
5974 * allocated, then copied. If the replacement for every character in every
5975 * possible string takes up no more bytes than the character it
5976 * replaces, then it can be edited in place. Otherwise the replacement
5977 * could overwrite a byte we are about to read, depending on the strings
5978 * being processed. The comments and variable names here refer to this as
5979 * "growing". Some inputs won't grow, and might even shrink under /d, but
5980 * some inputs could grow, so we have to assume any given one might grow.
5981 * On very long inputs, the temporary could eat up a lot of memory, so we
5982 * want to avoid it if possible. For non-UTF-8 inputs, everything is
5983 * single-byte, so can be edited in place, unless there is something in the
5984 * pattern that could force it into UTF-8. The inversion map makes it
5985 * feasible to determine this. Previous versions of this code pretty much
5986 * punted on determining if UTF-8 could be edited in place. Now, this code
5987 * is rigorous in making that determination.
5988 *
5989 * Another characteristic we need to know is whether the lhs and rhs are
5990 * identical. If so, and no other flags are present, the only effect of
5991 * the tr/// is to count the characters present in the input that are
5992 * mentioned in the lhs string. The implementation of that is easier and
5993 * runs faster than the more general case. Normalizing here allows for
5994 * accurate determination of this. Previously there were false negatives
5995 * possible.
5996 *
5997 * Instead of 'transliterated', the comments here use 'unmapped' for the
5998 * characters that are left unchanged by the operation; otherwise they are
5999 * 'mapped'
6000 *
6001 * The lhs of the tr/// is here referred to as the t side.
6002 * The rhs of the tr/// is here referred to as the r side.
6003 */
6004
6005 SV * const tstr = cSVOPx(expr)->op_sv;
6006 SV * const rstr = cSVOPx(repl)->op_sv;
6007 STRLEN tlen;
6008 STRLEN rlen;
6009 const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
6010 const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
6011 const U8 * t = t0;
6012 const U8 * r = r0;
6013 UV t_count = 0, r_count = 0; /* Number of characters in search and
6014 replacement lists */
6015
6016 /* khw thinks some of the private flags for this op are quaintly named.
6017 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
6018 * character when represented in UTF-8 is longer than the original
6019 * character's UTF-8 representation */
6020 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6021 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6022 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6023
6024 /* Set to true if there is some character < 256 in the lhs that maps to
6025 * above 255. If so, a non-UTF-8 match string can be forced into being in
6026 * UTF-8 by a tr/// operation. */
6027 bool can_force_utf8 = FALSE;
6028
6029 /* What is the maximum expansion factor in UTF-8 transliterations. If a
6030 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
6031 * expansion factor is 1.5. This number is used at runtime to calculate
6032 * how much space to allocate for non-inplace transliterations. Without
6033 * this number, the worst case is 14, which is extremely unlikely to happen
6034 * in real life, and could require significant memory overhead. */
6035 NV max_expansion = 1.;
6036
6037 UV t_range_count, r_range_count, min_range_count;
6038 UV* t_array;
6039 SV* t_invlist;
6040 UV* r_map;
6041 UV r_cp = 0, t_cp = 0;
6042 UV t_cp_end = (UV) -1;
6043 UV r_cp_end;
6044 Size_t len;
6045 AV* invmap;
6046 UV final_map = TR_UNLISTED; /* The final character in the replacement
6047 list, updated as we go along. Initialize
6048 to something illegal */
6049
6050 bool rstr_utf8 = cBOOL(SvUTF8(rstr));
6051 bool tstr_utf8 = cBOOL(SvUTF8(tstr));
6052
6053 const U8* tend = t + tlen;
6054 const U8* rend = r + rlen;
6055
6056 SV * inverted_tstr = NULL;
6057
6058 Size_t i;
6059 unsigned int pass2;
6060
6061 /* This routine implements detection of a transliteration having a longer
6062 * UTF-8 representation than its source, by partitioning all the possible
6063 * code points of the platform into equivalence classes of the same UTF-8
6064 * byte length in the first pass. As it constructs the mappings, it carves
6065 * these up into smaller chunks, but doesn't merge any together. This
6066 * makes it easy to find the instances it's looking for. A second pass is
6067 * done after this has been determined which merges things together to
6068 * shrink the table for runtime. The table below is used for both ASCII
6069 * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically
6070 * increasing for code points below 256. To correct for that, the macro
6071 * CP_ADJUST defined below converts those code points to ASCII in the first
6072 * pass, and we use the ASCII partition values. That works because the
6073 * growth factor will be unaffected, which is all that is calculated during
6074 * the first pass. */
6075 UV PL_partition_by_byte_length[] = {
6076 0,
6077 0x80, /* Below this is 1 byte representations */
6078 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */
6079 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */
6080 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */
6081 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */
6082 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */
6083
6084 # ifdef UV_IS_QUAD
6085 ,
6086 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */
6087 # endif
6088
6089 };
6090
6091 PERL_ARGS_ASSERT_PMTRANS;
6092
6093 PL_hints |= HINT_BLOCK_SCOPE;
6094
6095 /* If /c, the search list is sorted and complemented. This is now done by
6096 * creating an inversion list from it, and then trivially inverting that.
6097 * The previous implementation used qsort, but creating the list
6098 * automatically keeps it sorted as we go along */
6099 if (complement) {
6100 UV start, end;
6101 SV * inverted_tlist = _new_invlist(tlen);
6102 Size_t temp_len;
6103
6104 DEBUG_y(PerlIO_printf(Perl_debug_log,
6105 "%s: %d: tstr before inversion=\n%s\n",
6106 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
6107
6108 while (t < tend) {
6109
6110 /* Non-utf8 strings don't have ranges, so each character is listed
6111 * out */
6112 if (! tstr_utf8) {
6113 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
6114 t++;
6115 }
6116 else { /* But UTF-8 strings have been parsed in toke.c to have
6117 * ranges if appropriate. */
6118 UV t_cp;
6119 Size_t t_char_len;
6120
6121 /* Get the first character */
6122 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
6123 t += t_char_len;
6124
6125 /* If the next byte indicates that this wasn't the first
6126 * element of a range, the range is just this one */
6127 if (t >= tend || *t != RANGE_INDICATOR) {
6128 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
6129 }
6130 else { /* Otherwise, ignore the indicator byte, and get the
6131 final element, and add the whole range */
6132 t++;
6133 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
6134 t += t_char_len;
6135
6136 inverted_tlist = _add_range_to_invlist(inverted_tlist,
6137 t_cp, t_cp_end);
6138 }
6139 }
6140 } /* End of parse through tstr */
6141
6142 /* The inversion list is done; now invert it */
6143 _invlist_invert(inverted_tlist);
6144
6145 /* Now go through the inverted list and create a new tstr for the rest
6146 * of the routine to use. Since the UTF-8 version can have ranges, and
6147 * can be much more compact than the non-UTF-8 version, we create the
6148 * string in UTF-8 even if not necessary. (This is just an intermediate
6149 * value that gets thrown away anyway.) */
6150 invlist_iterinit(inverted_tlist);
6151 inverted_tstr = newSVpvs("");
6152 while (invlist_iternext(inverted_tlist, &start, &end)) {
6153 U8 temp[UTF8_MAXBYTES];
6154 U8 * temp_end_pos;
6155
6156 /* IV_MAX keeps things from going out of bounds */
6157 start = MIN(IV_MAX, start);
6158 end = MIN(IV_MAX, end);
6159
6160 temp_end_pos = uvchr_to_utf8(temp, start);
6161 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
6162
6163 if (start != end) {
6164 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
6165 temp_end_pos = uvchr_to_utf8(temp, end);
6166 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
6167 }
6168 }
6169
6170 /* Set up so the remainder of the routine uses this complement, instead
6171 * of the actual input */
6172 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
6173 tend = t0 + temp_len;
6174 tstr_utf8 = TRUE;
6175
6176 SvREFCNT_dec_NN(inverted_tlist);
6177 }
6178
6179 /* For non-/d, an empty rhs means to use the lhs */
6180 if (rlen == 0 && ! del) {
6181 r0 = t0;
6182 rend = tend;
6183 rstr_utf8 = tstr_utf8;
6184 }
6185
6186 t_invlist = _new_invlist(1);
6187
6188 /* Initialize to a single range */
6189 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
6190
6191 /* Below, we parse the (potentially adjusted) input, creating the inversion
6192 * map. This is done in two passes. The first pass is just to determine
6193 * if the transliteration can be done in-place. It can be done in place if
6194 * no possible inputs result in the replacement taking up more bytes than
6195 * the input. To figure that out, in the first pass we start with all the
6196 * possible code points partitioned into ranges so that every code point in
6197 * a range occupies the same number of UTF-8 bytes as every other code
6198 * point in the range. Constructing the inversion map doesn't merge ranges
6199 * together, but can split them into multiple ones. Given the starting
6200 * partition, the ending state will also have the same characteristic,
6201 * namely that each code point in each partition requires the same number
6202 * of UTF-8 bytes to represent as every other code point in the same
6203 * partition.
6204 *
6205 * This partitioning has been pre-compiled. Copy it to initialize */
6206 len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
6207 invlist_extend(t_invlist, len);
6208 t_array = invlist_array(t_invlist);
6209 Copy(PL_partition_by_byte_length, t_array, len, UV);
6210 invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
6211 Newx(r_map, len + 1, UV);
6212
6213 /* The inversion map the first pass creates could be used as-is, but
6214 * generally would be larger and slower to run than the output of the
6215 * second pass. */
6216
6217 for (pass2 = 0; pass2 < 2; pass2++) {
6218 if (pass2) {
6219 /* In the second pass, we start with a single range */
6220 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
6221 len = 1;
6222 t_array = invlist_array(t_invlist);
6223 }
6224
6225 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
6226 * so as to get the well-behaved length 1 vs length 2 boundary. Only code
6227 * points below 256 differ between the two character sets in this regard. For
6228 * these, we also can't have any ranges, as they have to be individually
6229 * converted. */
6230 #ifdef EBCDIC
6231 # define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x))
6232 # define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256))
6233 # define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
6234 #else
6235 # define CP_ADJUST(x) (x)
6236 # define FORCE_RANGE_LEN_1(x) 0
6237 # define CP_SKIP(x) UVCHR_SKIP(x)
6238 #endif
6239
6240 /* And the mapping of each of the ranges is initialized. Initially,
6241 * everything is TR_UNLISTED. */
6242 for (i = 0; i < len; i++) {
6243 r_map[i] = TR_UNLISTED;
6244 }
6245
6246 t = t0;
6247 t_count = 0;
6248 r = r0;
6249 r_count = 0;
6250 t_range_count = r_range_count = 0;
6251
6252 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
6253 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
6254 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
6255 _byte_dump_string(r, rend - r, 0)));
6256 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
6257 complement, squash, del));
6258 DEBUG_y(invmap_dump(t_invlist, r_map));
6259
6260 /* Now go through the search list constructing an inversion map. The
6261 * input is not necessarily in any particular order. Making it an
6262 * inversion map orders it, potentially simplifying, and makes it easy
6263 * to deal with at run time. This is the only place in core that
6264 * generates an inversion map; if others were introduced, it might be
6265 * better to create general purpose routines to handle them.
6266 * (Inversion maps are created in perl in other places.)
6267 *
6268 * An inversion map consists of two parallel arrays. One is
6269 * essentially an inversion list: an ordered list of code points such
6270 * that each element gives the first code point of a range of
6271 * consecutive code points that map to the element in the other array
6272 * that has the same index as this one (in other words, the
6273 * corresponding element). Thus the range extends up to (but not
6274 * including) the code point given by the next higher element. In a
6275 * true inversion map, the corresponding element in the other array
6276 * gives the mapping of the first code point in the range, with the
6277 * understanding that the next higher code point in the inversion
6278 * list's range will map to the next higher code point in the map.
6279 *
6280 * So if at element [i], let's say we have:
6281 *
6282 * t_invlist r_map
6283 * [i] A a
6284 *
6285 * This means that A => a, B => b, C => c.... Let's say that the
6286 * situation is such that:
6287 *
6288 * [i+1] L -1
6289 *
6290 * This means the sequence that started at [i] stops at K => k. This
6291 * illustrates that you need to look at the next element to find where
6292 * a sequence stops. Except, the highest element in the inversion list
6293 * begins a range that is understood to extend to the platform's
6294 * infinity.
6295 *
6296 * This routine modifies traditional inversion maps to reserve two
6297 * mappings:
6298 *
6299 * TR_UNLISTED (or -1) indicates that no code point in the range
6300 * is listed in the tr/// searchlist. At runtime, these are
6301 * always passed through unchanged. In the inversion map, all
6302 * points in the range are mapped to -1, instead of increasing,
6303 * like the 'L' in the example above.
6304 *
6305 * We start the parse with every code point mapped to this, and as
6306 * we parse and find ones that are listed in the search list, we
6307 * carve out ranges as we go along that override that.
6308 *
6309 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
6310 * range needs special handling. Again, all code points in the
6311 * range are mapped to -2, instead of increasing.
6312 *
6313 * Under /d this value means the code point should be deleted from
6314 * the transliteration when encountered.
6315 *
6316 * Otherwise, it marks that every code point in the range is to
6317 * map to the final character in the replacement list. This
6318 * happens only when the replacement list is shorter than the
6319 * search one, so there are things in the search list that have no
6320 * correspondence in the replacement list. For example, in
6321 * tr/a-z/A/, 'A' is the final value, and the inversion map
6322 * generated for this would be like this:
6323 * \0 => -1
6324 * a => A
6325 * b-z => -2
6326 * z+1 => -1
6327 * 'A' appears once, then the remainder of the range maps to -2.
6328 * The use of -2 isn't strictly necessary, as an inversion map is
6329 * capable of representing this situation, but not nearly so
6330 * compactly, and this is actually quite commonly encountered.
6331 * Indeed, the original design of this code used a full inversion
6332 * map for this. But things like
6333 * tr/\0-\x{FFFF}/A/
6334 * generated huge data structures, slowly, and the execution was
6335 * also slow. So the current scheme was implemented.
6336 *
6337 * So, if the next element in our example is:
6338 *
6339 * [i+2] Q q
6340 *
6341 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next
6342 * elements are
6343 *
6344 * [i+3] R z
6345 * [i+4] S TR_UNLISTED
6346 *
6347 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is
6348 * the final element in the arrays, every code point from S to infinity
6349 * maps to TR_UNLISTED.
6350 *
6351 */
6352 /* Finish up range started in what otherwise would
6353 * have been the final iteration */
6354 while (t < tend || t_range_count > 0) {
6355 bool adjacent_to_range_above = FALSE;
6356 bool adjacent_to_range_below = FALSE;
6357
6358 bool merge_with_range_above = FALSE;
6359 bool merge_with_range_below = FALSE;
6360
6361 UV span, invmap_range_length_remaining;
6362 SSize_t j;
6363 Size_t i;
6364
6365 /* If we are in the middle of processing a range in the 'target'
6366 * side, the previous iteration has set us up. Otherwise, look at
6367 * the next character in the search list */
6368 if (t_range_count <= 0) {
6369 if (! tstr_utf8) {
6370
6371 /* Here, not in the middle of a range, and not UTF-8. The
6372 * next code point is the single byte where we're at */
6373 t_cp = CP_ADJUST(*t);
6374 t_range_count = 1;
6375 t++;
6376 }
6377 else {
6378 Size_t t_char_len;
6379
6380 /* Here, not in the middle of a range, and is UTF-8. The
6381 * next code point is the next UTF-8 char in the input. We
6382 * know the input is valid, because the toker constructed
6383 * it */
6384 t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
6385 t += t_char_len;
6386
6387 /* UTF-8 strings (only) have been parsed in toke.c to have
6388 * ranges. See if the next byte indicates that this was
6389 * the first element of a range. If so, get the final
6390 * element and calculate the range size. If not, the range
6391 * size is 1 */
6392 if ( t < tend && *t == RANGE_INDICATOR
6393 && ! FORCE_RANGE_LEN_1(t_cp))
6394 {
6395 t++;
6396 t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
6397 - t_cp + 1;
6398 t += t_char_len;
6399 }
6400 else {
6401 t_range_count = 1;
6402 }
6403 }
6404
6405 /* Count the total number of listed code points * */
6406 t_count += t_range_count;
6407 }
6408
6409 /* Similarly, get the next character in the replacement list */
6410 if (r_range_count <= 0) {
6411 if (r >= rend) {
6412
6413 /* But if we've exhausted the rhs, there is nothing to map
6414 * to, except the special handling one, and we make the
6415 * range the same size as the lhs one. */
6416 r_cp = TR_SPECIAL_HANDLING;
6417 r_range_count = t_range_count;
6418
6419 if (! del) {
6420 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6421 "final_map =%" UVXf "\n", final_map));
6422 }
6423 }
6424 else {
6425 if (! rstr_utf8) {
6426 r_cp = CP_ADJUST(*r);
6427 r_range_count = 1;
6428 r++;
6429 }
6430 else {
6431 Size_t r_char_len;
6432
6433 r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
6434 r += r_char_len;
6435 if ( r < rend && *r == RANGE_INDICATOR
6436 && ! FORCE_RANGE_LEN_1(r_cp))
6437 {
6438 r++;
6439 r_range_count = valid_utf8_to_uvchr(r,
6440 &r_char_len) - r_cp + 1;
6441 r += r_char_len;
6442 }
6443 else {
6444 r_range_count = 1;
6445 }
6446 }
6447
6448 if (r_cp == TR_SPECIAL_HANDLING) {
6449 r_range_count = t_range_count;
6450 }
6451
6452 /* This is the final character so far */
6453 final_map = r_cp + r_range_count - 1;
6454
6455 r_count += r_range_count;
6456 }
6457 }
6458
6459 /* Here, we have the next things ready in both sides. They are
6460 * potentially ranges. We try to process as big a chunk as
6461 * possible at once, but the lhs and rhs must be synchronized, so
6462 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
6463 * */
6464 min_range_count = MIN(t_range_count, r_range_count);
6465
6466 /* Search the inversion list for the entry that contains the input
6467 * code point <cp>. The inversion map was initialized to cover the
6468 * entire range of possible inputs, so this should not fail. So
6469 * the return value is the index into the list's array of the range
6470 * that contains <cp>, that is, 'i' such that array[i] <= cp <
6471 * array[i+1] */
6472 j = _invlist_search(t_invlist, t_cp);
6473 assert(j >= 0);
6474 i = j;
6475
6476 /* Here, the data structure might look like:
6477 *
6478 * index t r Meaning
6479 * [i-1] J j # J-L => j-l
6480 * [i] M -1 # M => default; as do N, O, P, Q
6481 * [i+1] R x # R => x, S => x+1, T => x+2
6482 * [i+2] U y # U => y, V => y+1, ...
6483 * ...
6484 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6485 *
6486 * where 'x' and 'y' above are not to be taken literally.
6487 *
6488 * The maximum chunk we can handle in this loop iteration, is the
6489 * smallest of the three components: the lhs 't_', the rhs 'r_',
6490 * and the remainder of the range in element [i]. (In pass 1, that
6491 * range will have everything in it be of the same class; we can't
6492 * cross into another class.) 'min_range_count' already contains
6493 * the smallest of the first two values. The final one is
6494 * irrelevant if the map is to the special indicator */
6495
6496 invmap_range_length_remaining = (i + 1 < len)
6497 ? t_array[i+1] - t_cp
6498 : IV_MAX - t_cp;
6499 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
6500
6501 /* The end point of this chunk is where we are, plus the span, but
6502 * never larger than the platform's infinity */
6503 t_cp_end = MIN(IV_MAX, t_cp + span - 1);
6504
6505 if (r_cp == TR_SPECIAL_HANDLING) {
6506
6507 /* If unmatched lhs code points map to the final map, use that
6508 * value. This being set to TR_SPECIAL_HANDLING indicates that
6509 * we don't have a final map: unmatched lhs code points are
6510 * simply deleted */
6511 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
6512 }
6513 else {
6514 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
6515
6516 /* If something on the lhs is below 256, and something on the
6517 * rhs is above, there is a potential mapping here across that
6518 * boundary. Indeed the only way there isn't is if both sides
6519 * start at the same point. That means they both cross at the
6520 * same time. But otherwise one crosses before the other */
6521 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
6522 can_force_utf8 = TRUE;
6523 }
6524 }
6525
6526 /* If a character appears in the search list more than once, the
6527 * 2nd and succeeding occurrences are ignored, so only do this
6528 * range if haven't already processed this character. (The range
6529 * has been set up so that all members in it will be of the same
6530 * ilk) */
6531 if (r_map[i] == TR_UNLISTED) {
6532 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6533 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
6534 t_cp, t_cp_end, r_cp, r_cp_end));
6535
6536 /* This is the first definition for this chunk, hence is valid
6537 * and needs to be processed. Here and in the comments below,
6538 * we use the above sample data. The t_cp chunk must be any
6539 * contiguous subset of M, N, O, P, and/or Q.
6540 *
6541 * In the first pass, calculate if there is any possible input
6542 * string that has a character whose transliteration will be
6543 * longer than it. If none, the transliteration may be done
6544 * in-place, as it can't write over a so-far unread byte.
6545 * Otherwise, a copy must first be made. This could be
6546 * expensive for long inputs.
6547 *
6548 * In the first pass, the t_invlist has been partitioned so
6549 * that all elements in any single range have the same number
6550 * of bytes in their UTF-8 representations. And the r space is
6551 * either a single byte, or a range of strictly monotonically
6552 * increasing code points. So the final element in the range
6553 * will be represented by no fewer bytes than the initial one.
6554 * That means that if the final code point in the t range has
6555 * at least as many bytes as the final code point in the r,
6556 * then all code points in the t range have at least as many
6557 * bytes as their corresponding r range element. But if that's
6558 * not true, the transliteration of at least the final code
6559 * point grows in length. As an example, suppose we had
6560 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
6561 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
6562 * platforms. We have deliberately set up the data structure
6563 * so that any range in the lhs gets split into chunks for
6564 * processing, such that every code point in a chunk has the
6565 * same number of UTF-8 bytes. We only have to check the final
6566 * code point in the rhs against any code point in the lhs. */
6567 if ( ! pass2
6568 && r_cp_end != TR_SPECIAL_HANDLING
6569 && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
6570 {
6571 /* Here, we will need to make a copy of the input string
6572 * before doing the transliteration. The worst possible
6573 * case is an expansion ratio of 14:1. This is rare, and
6574 * we'd rather allocate only the necessary amount of extra
6575 * memory for that copy. We can calculate the worst case
6576 * for this particular transliteration is by keeping track
6577 * of the expansion factor for each range.
6578 *
6579 * Consider tr/\xCB/\X{E000}/. The maximum expansion
6580 * factor is 1 byte going to 3 if the target string is not
6581 * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We
6582 * could pass two different values so doop could choose
6583 * based on the UTF-8ness of the target. But khw thinks
6584 * (perhaps wrongly) that is overkill. It is used only to
6585 * make sure we malloc enough space.
6586 *
6587 * If no target string can force the result to be UTF-8,
6588 * then we don't have to worry about the case of the target
6589 * string not being UTF-8 */
6590 NV t_size = (can_force_utf8 && t_cp < 256)
6591 ? 1
6592 : CP_SKIP(t_cp_end);
6593 NV ratio = CP_SKIP(r_cp_end) / t_size;
6594
6595 o->op_private |= OPpTRANS_GROWS;
6596
6597 /* Now that we know it grows, we can keep track of the
6598 * largest ratio */
6599 if (ratio > max_expansion) {
6600 max_expansion = ratio;
6601 DEBUG_y(PerlIO_printf(Perl_debug_log,
6602 "New expansion factor: %" NVgf "\n",
6603 max_expansion));
6604 }
6605 }
6606
6607 /* The very first range is marked as adjacent to the
6608 * non-existent range below it, as it causes things to "just
6609 * work" (TradeMark)
6610 *
6611 * If the lowest code point in this chunk is M, it adjoins the
6612 * J-L range */
6613 if (t_cp == t_array[i]) {
6614 adjacent_to_range_below = TRUE;
6615
6616 /* And if the map has the same offset from the beginning of
6617 * the range as does this new code point (or both are for
6618 * TR_SPECIAL_HANDLING), this chunk can be completely
6619 * merged with the range below. EXCEPT, in the first pass,
6620 * we don't merge ranges whose UTF-8 byte representations
6621 * have different lengths, so that we can more easily
6622 * detect if a replacement is longer than the source, that
6623 * is if it 'grows'. But in the 2nd pass, there's no
6624 * reason to not merge */
6625 if ( (i > 0 && ( pass2
6626 || CP_SKIP(t_array[i-1])
6627 == CP_SKIP(t_cp)))
6628 && ( ( r_cp == TR_SPECIAL_HANDLING
6629 && r_map[i-1] == TR_SPECIAL_HANDLING)
6630 || ( r_cp != TR_SPECIAL_HANDLING
6631 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
6632 {
6633 merge_with_range_below = TRUE;
6634 }
6635 }
6636
6637 /* Similarly, if the highest code point in this chunk is 'Q',
6638 * it adjoins the range above, and if the map is suitable, can
6639 * be merged with it */
6640 if ( t_cp_end >= IV_MAX - 1
6641 || ( i + 1 < len
6642 && t_cp_end + 1 == t_array[i+1]))
6643 {
6644 adjacent_to_range_above = TRUE;
6645 if (i + 1 < len)
6646 if ( ( pass2
6647 || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
6648 && ( ( r_cp == TR_SPECIAL_HANDLING
6649 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
6650 || ( r_cp != TR_SPECIAL_HANDLING
6651 && r_cp_end == r_map[i+1] - 1)))
6652 {
6653 merge_with_range_above = TRUE;
6654 }
6655 }
6656
6657 if (merge_with_range_below && merge_with_range_above) {
6658
6659 /* Here the new chunk looks like M => m, ... Q => q; and
6660 * the range above is like R => r, .... Thus, the [i-1]
6661 * and [i+1] ranges should be seamlessly melded so the
6662 * result looks like
6663 *
6664 * [i-1] J j # J-T => j-t
6665 * [i] U y # U => y, V => y+1, ...
6666 * ...
6667 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6668 */
6669 Move(t_array + i + 2, t_array + i, len - i - 2, UV);
6670 Move(r_map + i + 2, r_map + i, len - i - 2, UV);
6671 len -= 2;
6672 invlist_set_len(t_invlist,
6673 len,
6674 *(get_invlist_offset_addr(t_invlist)));
6675 }
6676 else if (merge_with_range_below) {
6677
6678 /* Here the new chunk looks like M => m, .... But either
6679 * (or both) it doesn't extend all the way up through Q; or
6680 * the range above doesn't start with R => r. */
6681 if (! adjacent_to_range_above) {
6682
6683 /* In the first case, let's say the new chunk extends
6684 * through O. We then want:
6685 *
6686 * [i-1] J j # J-O => j-o
6687 * [i] P -1 # P => -1, Q => -1
6688 * [i+1] R x # R => x, S => x+1, T => x+2
6689 * [i+2] U y # U => y, V => y+1, ...
6690 * ...
6691 * [-1] Z -1 # Z => default; as do Z+1, ...
6692 * infinity
6693 */
6694 t_array[i] = t_cp_end + 1;
6695 r_map[i] = TR_UNLISTED;
6696 }
6697 else { /* Adjoins the range above, but can't merge with it
6698 (because 'x' is not the next map after q) */
6699 /*
6700 * [i-1] J j # J-Q => j-q
6701 * [i] R x # R => x, S => x+1, T => x+2
6702 * [i+1] U y # U => y, V => y+1, ...
6703 * ...
6704 * [-1] Z -1 # Z => default; as do Z+1, ...
6705 * infinity
6706 */
6707
6708 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
6709 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
6710 len--;
6711 invlist_set_len(t_invlist, len,
6712 *(get_invlist_offset_addr(t_invlist)));
6713 }
6714 }
6715 else if (merge_with_range_above) {
6716
6717 /* Here the new chunk ends with Q => q, and the range above
6718 * must start with R => r, so the two can be merged. But
6719 * either (or both) the new chunk doesn't extend all the
6720 * way down to M; or the mapping of the final code point
6721 * range below isn't m */
6722 if (! adjacent_to_range_below) {
6723
6724 /* In the first case, let's assume the new chunk starts
6725 * with P => p. Then, because it's merge-able with the
6726 * range above, that range must be R => r. We want:
6727 *
6728 * [i-1] J j # J-L => j-l
6729 * [i] M -1 # M => -1, N => -1
6730 * [i+1] P p # P-T => p-t
6731 * [i+2] U y # U => y, V => y+1, ...
6732 * ...
6733 * [-1] Z -1 # Z => default; as do Z+1, ...
6734 * infinity
6735 */
6736 t_array[i+1] = t_cp;
6737 r_map[i+1] = r_cp;
6738 }
6739 else { /* Adjoins the range below, but can't merge with it
6740 */
6741 /*
6742 * [i-1] J j # J-L => j-l
6743 * [i] M x # M-T => x-5 .. x+2
6744 * [i+1] U y # U => y, V => y+1, ...
6745 * ...
6746 * [-1] Z -1 # Z => default; as do Z+1, ...
6747 * infinity
6748 */
6749 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
6750 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
6751 len--;
6752 t_array[i] = t_cp;
6753 r_map[i] = r_cp;
6754 invlist_set_len(t_invlist, len,
6755 *(get_invlist_offset_addr(t_invlist)));
6756 }
6757 }
6758 else if (adjacent_to_range_below && adjacent_to_range_above) {
6759 /* The new chunk completely fills the gap between the
6760 * ranges on either side, but can't merge with either of
6761 * them.
6762 *
6763 * [i-1] J j # J-L => j-l
6764 * [i] M z # M => z, N => z+1 ... Q => z+4
6765 * [i+1] R x # R => x, S => x+1, T => x+2
6766 * [i+2] U y # U => y, V => y+1, ...
6767 * ...
6768 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6769 */
6770 r_map[i] = r_cp;
6771 }
6772 else if (adjacent_to_range_below) {
6773 /* The new chunk adjoins the range below, but not the range
6774 * above, and can't merge. Let's assume the chunk ends at
6775 * O.
6776 *
6777 * [i-1] J j # J-L => j-l
6778 * [i] M z # M => z, N => z+1, O => z+2
6779 * [i+1] P -1 # P => -1, Q => -1
6780 * [i+2] R x # R => x, S => x+1, T => x+2
6781 * [i+3] U y # U => y, V => y+1, ...
6782 * ...
6783 * [-w] Z -1 # Z => default; as do Z+1, ... infinity
6784 */
6785 invlist_extend(t_invlist, len + 1);
6786 t_array = invlist_array(t_invlist);
6787 Renew(r_map, len + 1, UV);
6788
6789 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
6790 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
6791 r_map[i] = r_cp;
6792 t_array[i+1] = t_cp_end + 1;
6793 r_map[i+1] = TR_UNLISTED;
6794 len++;
6795 invlist_set_len(t_invlist, len,
6796 *(get_invlist_offset_addr(t_invlist)));
6797 }
6798 else if (adjacent_to_range_above) {
6799 /* The new chunk adjoins the range above, but not the range
6800 * below, and can't merge. Let's assume the new chunk
6801 * starts at O
6802 *
6803 * [i-1] J j # J-L => j-l
6804 * [i] M -1 # M => default, N => default
6805 * [i+1] O z # O => z, P => z+1, Q => z+2
6806 * [i+2] R x # R => x, S => x+1, T => x+2
6807 * [i+3] U y # U => y, V => y+1, ...
6808 * ...
6809 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6810 */
6811 invlist_extend(t_invlist, len + 1);
6812 t_array = invlist_array(t_invlist);
6813 Renew(r_map, len + 1, UV);
6814
6815 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
6816 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
6817 t_array[i+1] = t_cp;
6818 r_map[i+1] = r_cp;
6819 len++;
6820 invlist_set_len(t_invlist, len,
6821 *(get_invlist_offset_addr(t_invlist)));
6822 }
6823 else {
6824 /* The new chunk adjoins neither the range above, nor the
6825 * range below. Lets assume it is N..P => n..p
6826 *
6827 * [i-1] J j # J-L => j-l
6828 * [i] M -1 # M => default
6829 * [i+1] N n # N..P => n..p
6830 * [i+2] Q -1 # Q => default
6831 * [i+3] R x # R => x, S => x+1, T => x+2
6832 * [i+4] U y # U => y, V => y+1, ...
6833 * ...
6834 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6835 */
6836
6837 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6838 "Before fixing up: len=%d, i=%d\n",
6839 (int) len, (int) i));
6840 DEBUG_yv(invmap_dump(t_invlist, r_map));
6841
6842 invlist_extend(t_invlist, len + 2);
6843 t_array = invlist_array(t_invlist);
6844 Renew(r_map, len + 2, UV);
6845
6846 Move(t_array + i + 1,
6847 t_array + i + 2 + 1, len - i - (2 - 1), UV);
6848 Move(r_map + i + 1,
6849 r_map + i + 2 + 1, len - i - (2 - 1), UV);
6850
6851 len += 2;
6852 invlist_set_len(t_invlist, len,
6853 *(get_invlist_offset_addr(t_invlist)));
6854
6855 t_array[i+1] = t_cp;
6856 r_map[i+1] = r_cp;
6857
6858 t_array[i+2] = t_cp_end + 1;
6859 r_map[i+2] = TR_UNLISTED;
6860 }
6861 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6862 "After iteration: span=%" UVuf ", t_range_count=%"
6863 UVuf " r_range_count=%" UVuf "\n",
6864 span, t_range_count, r_range_count));
6865 DEBUG_yv(invmap_dump(t_invlist, r_map));
6866 } /* End of this chunk needs to be processed */
6867
6868 /* Done with this chunk. */
6869 t_cp += span;
6870 if (t_cp >= IV_MAX) {
6871 break;
6872 }
6873 t_range_count -= span;
6874 if (r_cp != TR_SPECIAL_HANDLING) {
6875 r_cp += span;
6876 r_range_count -= span;
6877 }
6878 else {
6879 r_range_count = 0;
6880 }
6881
6882 } /* End of loop through the search list */
6883
6884 /* We don't need an exact count, but we do need to know if there is
6885 * anything left over in the replacement list. So, just assume it's
6886 * one byte per character */
6887 if (rend > r) {
6888 r_count++;
6889 }
6890 } /* End of passes */
6891
6892 SvREFCNT_dec(inverted_tstr);
6893
6894 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
6895 DEBUG_y(invmap_dump(t_invlist, r_map));
6896
6897 /* We now have normalized the input into an inversion map.
6898 *
6899 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op
6900 * except for the count, and streamlined runtime code can be used */
6901 if (!del && !squash) {
6902
6903 /* They are identical if they point to the same address, or if
6904 * everything maps to UNLISTED or to itself. This catches things that
6905 * not looking at the normalized inversion map doesn't catch, like
6906 * tr/aa/ab/ or tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */
6907 if (r0 != t0) {
6908 for (i = 0; i < len; i++) {
6909 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
6910 goto done_identical_check;
6911 }
6912 }
6913 }
6914
6915 /* Here have gone through entire list, and didn't find any
6916 * non-identical mappings */
6917 o->op_private |= OPpTRANS_IDENTICAL;
6918
6919 done_identical_check: ;
6920 }
6921
6922 t_array = invlist_array(t_invlist);
6923
6924 /* If has components above 255, we generally need to use the inversion map
6925 * implementation */
6926 if ( can_force_utf8
6927 || ( len > 0
6928 && t_array[len-1] > 255
6929 /* If the final range is 0x100-INFINITY and is a special
6930 * mapping, the table implementation can handle it */
6931 && ! ( t_array[len-1] == 256
6932 && ( r_map[len-1] == TR_UNLISTED
6933 || r_map[len-1] == TR_SPECIAL_HANDLING))))
6934 {
6935 SV* r_map_sv;
6936 SV* temp_sv;
6937
6938 /* A UTF-8 op is generated, indicated by this flag. This op is an
6939 * sv_op */
6940 o->op_private |= OPpTRANS_USE_SVOP;
6941
6942 if (can_force_utf8) {
6943 o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
6944 }
6945
6946 /* The inversion map is pushed; first the list. */
6947 invmap = MUTABLE_AV(newAV());
6948
6949 SvREADONLY_on(t_invlist);
6950 av_push(invmap, t_invlist);
6951
6952 /* 2nd is the mapping */
6953 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
6954 SvREADONLY_on(r_map_sv);
6955 av_push(invmap, r_map_sv);
6956
6957 /* 3rd is the max possible expansion factor */
6958 temp_sv = newSVnv(max_expansion);
6959 SvREADONLY_on(temp_sv);
6960 av_push(invmap, temp_sv);
6961
6962 /* Characters that are in the search list, but not in the replacement
6963 * list are mapped to the final character in the replacement list */
6964 if (! del && r_count < t_count) {
6965 temp_sv = newSVuv(final_map);
6966 SvREADONLY_on(temp_sv);
6967 av_push(invmap, temp_sv);
6968 }
6969
6970 #ifdef USE_ITHREADS
6971 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6972 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6973 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
6974 SvPADTMP_on(invmap);
6975 SvREADONLY_on(invmap);
6976 #else
6977 cSVOPo->op_sv = (SV *) invmap;
6978 #endif
6979
6980 }
6981 else {
6982 OPtrans_map *tbl;
6983 unsigned short i;
6984
6985 /* The OPtrans_map struct already contains one slot; hence the -1. */
6986 SSize_t struct_size = sizeof(OPtrans_map)
6987 + (256 - 1 + 1)*sizeof(short);
6988
6989 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6990 * table. Entries with the value TR_UNMAPPED indicate chars not to be
6991 * translated, while TR_DELETE indicates a search char without a
6992 * corresponding replacement char under /d.
6993 *
6994 * In addition, an extra slot at the end is used to store the final
6995 * repeating char, or TR_R_EMPTY under an empty replacement list, or
6996 * TR_DELETE under /d; which makes the runtime code easier. */
6997
6998 /* Indicate this is an op_pv */
6999 o->op_private &= ~OPpTRANS_USE_SVOP;
7000
7001 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7002 tbl->size = 256;
7003 cPVOPo->op_pv = (char*)tbl;
7004
7005 for (i = 0; i < len; i++) {
7006 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7007 short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7008 short to = (short) r_map[i];
7009 short j;
7010 bool do_increment = TRUE;
7011
7012 /* Any code points above our limit should be irrelevant */
7013 if (t_array[i] >= tbl->size) break;
7014
7015 /* Set up the map */
7016 if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7017 to = (short) final_map;
7018 do_increment = FALSE;
7019 }
7020 else if (to < 0) {
7021 do_increment = FALSE;
7022 }
7023
7024 /* Create a map for everything in this range. The value increases
7025 * except for the special cases */
7026 for (j = (short) t_array[i]; j < upper; j++) {
7027 tbl->map[j] = to;
7028 if (do_increment) to++;
7029 }
7030 }
7031
7032 tbl->map[tbl->size] = del
7033 ? (short) TR_DELETE
7034 : (short) rlen
7035 ? (short) final_map
7036 : (short) TR_R_EMPTY;
7037 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
7038 for (i = 0; i < tbl->size; i++) {
7039 if (tbl->map[i] < 0) {
7040 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
7041 (unsigned) i, tbl->map[i]));
7042 }
7043 else {
7044 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
7045 (unsigned) i, tbl->map[i]));
7046 }
7047 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
7048 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
7049 }
7050 }
7051 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
7052 (unsigned) tbl->size, tbl->map[tbl->size]));
7053
7054 SvREFCNT_dec(t_invlist);
7055
7056 #if 0 /* code that added excess above-255 chars at the end of the table, in
7057 case we ever want to not use the inversion map implementation for
7058 this */
7059
7060 ASSUME(j <= rlen);
7061 excess = rlen - j;
7062
7063 if (excess) {
7064 /* More replacement chars than search chars:
7065 * store excess replacement chars at end of main table.
7066 */
7067
7068 struct_size += excess;
7069 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
7070 struct_size + excess * sizeof(short));
7071 tbl->size += excess;
7072 cPVOPo->op_pv = (char*)tbl;
7073
7074 for (i = 0; i < excess; i++)
7075 tbl->map[i + 256] = r[j+i];
7076 }
7077 else {
7078 /* no more replacement chars than search chars */
7079 }
7080 #endif
7081
7082 }
7083
7084 DEBUG_y(PerlIO_printf(Perl_debug_log,
7085 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
7086 " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
7087 del, squash, complement,
7088 cBOOL(o->op_private & OPpTRANS_IDENTICAL),
7089 cBOOL(o->op_private & OPpTRANS_USE_SVOP),
7090 cBOOL(o->op_private & OPpTRANS_GROWS),
7091 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
7092 max_expansion));
7093
7094 Safefree(r_map);
7095
7096 if(del && rlen != 0 && r_count == t_count) {
7097 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
7098 } else if(r_count > t_count) {
7099 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
7100 }
7101
7102 op_free(expr);
7103 op_free(repl);
7104
7105 return o;
7106 }
7107
7108
7109 /*
7110 =for apidoc newPMOP
7111
7112 Constructs, checks, and returns an op of any pattern matching type.
7113 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
7114 and, shifted up eight bits, the eight bits of C<op_private>.
7115
7116 =cut
7117 */
7118
7119 OP *
Perl_newPMOP(pTHX_ I32 type,I32 flags)7120 Perl_newPMOP(pTHX_ I32 type, I32 flags)
7121 {
7122 PMOP *pmop;
7123
7124 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
7125 || type == OP_CUSTOM);
7126
7127 NewOp(1101, pmop, 1, PMOP);
7128 OpTYPE_set(pmop, type);
7129 pmop->op_flags = (U8)flags;
7130 pmop->op_private = (U8)(0 | (flags >> 8));
7131 if (PL_opargs[type] & OA_RETSCALAR)
7132 scalar((OP *)pmop);
7133
7134 if (PL_hints & HINT_RE_TAINT)
7135 pmop->op_pmflags |= PMf_RETAINT;
7136 #ifdef USE_LOCALE_CTYPE
7137 if (IN_LC_COMPILETIME(LC_CTYPE)) {
7138 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
7139 }
7140 else
7141 #endif
7142 if (IN_UNI_8_BIT) {
7143 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
7144 }
7145 if (PL_hints & HINT_RE_FLAGS) {
7146 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7147 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
7148 );
7149 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
7150 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7151 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
7152 );
7153 if (reflags && SvOK(reflags)) {
7154 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
7155 }
7156 }
7157
7158
7159 #ifdef USE_ITHREADS
7160 assert(SvPOK(PL_regex_pad[0]));
7161 if (SvCUR(PL_regex_pad[0])) {
7162 /* Pop off the "packed" IV from the end. */
7163 SV *const repointer_list = PL_regex_pad[0];
7164 const char *p = SvEND(repointer_list) - sizeof(IV);
7165 const IV offset = *((IV*)p);
7166
7167 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
7168
7169 SvEND_set(repointer_list, p);
7170
7171 pmop->op_pmoffset = offset;
7172 /* This slot should be free, so assert this: */
7173 assert(PL_regex_pad[offset] == &PL_sv_undef);
7174 } else {
7175 SV * const repointer = &PL_sv_undef;
7176 av_push(PL_regex_padav, repointer);
7177 pmop->op_pmoffset = av_top_index(PL_regex_padav);
7178 PL_regex_pad = AvARRAY(PL_regex_padav);
7179 }
7180 #endif
7181
7182 return CHECKOP(type, pmop);
7183 }
7184
7185 static void
S_set_haseval(pTHX)7186 S_set_haseval(pTHX)
7187 {
7188 PADOFFSET i = 1;
7189 PL_cv_has_eval = 1;
7190 /* Any pad names in scope are potentially lvalues. */
7191 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
7192 PADNAME *pn = PAD_COMPNAME_SV(i);
7193 if (!pn || !PadnameLEN(pn))
7194 continue;
7195 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
7196 S_mark_padname_lvalue(aTHX_ pn);
7197 }
7198 }
7199
7200 /* Given some sort of match op o, and an expression expr containing a
7201 * pattern, either compile expr into a regex and attach it to o (if it's
7202 * constant), or convert expr into a runtime regcomp op sequence (if it's
7203 * not)
7204 *
7205 * Flags currently has 2 bits of meaning:
7206 * 1: isreg indicates that the pattern is part of a regex construct, eg
7207 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
7208 * split "pattern", which aren't. In the former case, expr will be a list
7209 * if the pattern contains more than one term (eg /a$b/).
7210 * 2: The pattern is for a split.
7211 *
7212 * When the pattern has been compiled within a new anon CV (for
7213 * qr/(?{...})/ ), then floor indicates the savestack level just before
7214 * the new sub was created
7215 *
7216 * tr/// is also handled.
7217 */
7218
7219 OP *
Perl_pmruntime(pTHX_ OP * o,OP * expr,OP * repl,UV flags,I32 floor)7220 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
7221 {
7222 PMOP *pm;
7223 LOGOP *rcop;
7224 I32 repl_has_vars = 0;
7225 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
7226 bool is_compiletime;
7227 bool has_code;
7228 bool isreg = cBOOL(flags & 1);
7229 bool is_split = cBOOL(flags & 2);
7230
7231 PERL_ARGS_ASSERT_PMRUNTIME;
7232
7233 if (is_trans) {
7234 return pmtrans(o, expr, repl);
7235 }
7236
7237 /* find whether we have any runtime or code elements;
7238 * at the same time, temporarily set the op_next of each DO block;
7239 * then when we LINKLIST, this will cause the DO blocks to be excluded
7240 * from the op_next chain (and from having LINKLIST recursively
7241 * applied to them). We fix up the DOs specially later */
7242
7243 is_compiletime = 1;
7244 has_code = 0;
7245 if (expr->op_type == OP_LIST) {
7246 OP *child;
7247 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
7248 if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
7249 has_code = 1;
7250 assert(!child->op_next);
7251 if (UNLIKELY(!OpHAS_SIBLING(child))) {
7252 assert(PL_parser && PL_parser->error_count);
7253 /* This can happen with qr/ (?{(^{})/. Just fake up
7254 the op we were expecting to see, to avoid crashing
7255 elsewhere. */
7256 op_sibling_splice(expr, child, 0,
7257 newSVOP(OP_CONST, 0, &PL_sv_no));
7258 }
7259 child->op_next = OpSIBLING(child);
7260 }
7261 else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
7262 is_compiletime = 0;
7263 }
7264 }
7265 else if (expr->op_type != OP_CONST)
7266 is_compiletime = 0;
7267
7268 LINKLIST(expr);
7269
7270 /* fix up DO blocks; treat each one as a separate little sub;
7271 * also, mark any arrays as LIST/REF */
7272
7273 if (expr->op_type == OP_LIST) {
7274 OP *child;
7275 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
7276
7277 if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
7278 assert( !(child->op_flags & OPf_WANT));
7279 /* push the array rather than its contents. The regex
7280 * engine will retrieve and join the elements later */
7281 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
7282 continue;
7283 }
7284
7285 if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
7286 continue;
7287 child->op_next = NULL; /* undo temporary hack from above */
7288 scalar(child);
7289 LINKLIST(child);
7290 if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
7291 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
7292 /* skip ENTER */
7293 assert(leaveop->op_first->op_type == OP_ENTER);
7294 assert(OpHAS_SIBLING(leaveop->op_first));
7295 child->op_next = OpSIBLING(leaveop->op_first);
7296 /* skip leave */
7297 assert(leaveop->op_flags & OPf_KIDS);
7298 assert(leaveop->op_last->op_next == (OP*)leaveop);
7299 leaveop->op_next = NULL; /* stop on last op */
7300 op_null((OP*)leaveop);
7301 }
7302 else {
7303 /* skip SCOPE */
7304 OP *scope = cLISTOPx(child)->op_first;
7305 assert(scope->op_type == OP_SCOPE);
7306 assert(scope->op_flags & OPf_KIDS);
7307 scope->op_next = NULL; /* stop on last op */
7308 op_null(scope);
7309 }
7310
7311 /* XXX optimize_optree() must be called on o before
7312 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7313 * currently cope with a peephole-optimised optree.
7314 * Calling optimize_optree() here ensures that condition
7315 * is met, but may mean optimize_optree() is applied
7316 * to the same optree later (where hopefully it won't do any
7317 * harm as it can't convert an op to multiconcat if it's
7318 * already been converted */
7319 optimize_optree(child);
7320
7321 /* have to peep the DOs individually as we've removed it from
7322 * the op_next chain */
7323 CALL_PEEP(child);
7324 op_prune_chain_head(&(child->op_next));
7325 if (is_compiletime)
7326 /* runtime finalizes as part of finalizing whole tree */
7327 finalize_optree(child);
7328 }
7329 }
7330 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7331 assert( !(expr->op_flags & OPf_WANT));
7332 /* push the array rather than its contents. The regex
7333 * engine will retrieve and join the elements later */
7334 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7335 }
7336
7337 PL_hints |= HINT_BLOCK_SCOPE;
7338 pm = cPMOPo;
7339 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7340
7341 if (is_compiletime) {
7342 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7343 regexp_engine const *eng = current_re_engine();
7344
7345 if (is_split) {
7346 /* make engine handle split ' ' specially */
7347 pm->op_pmflags |= PMf_SPLIT;
7348 rx_flags |= RXf_SPLIT;
7349 }
7350
7351 if (!has_code || !eng->op_comp) {
7352 /* compile-time simple constant pattern */
7353
7354 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7355 /* whoops! we guessed that a qr// had a code block, but we
7356 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7357 * that isn't required now. Note that we have to be pretty
7358 * confident that nothing used that CV's pad while the
7359 * regex was parsed, except maybe op targets for \Q etc.
7360 * If there were any op targets, though, they should have
7361 * been stolen by constant folding.
7362 */
7363 #ifdef DEBUGGING
7364 SSize_t i = 0;
7365 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7366 while (++i <= AvFILLp(PL_comppad)) {
7367 # ifdef USE_PAD_RESET
7368 /* under USE_PAD_RESET, pad swipe replaces a swiped
7369 * folded constant with a fresh padtmp */
7370 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7371 # else
7372 assert(!PL_curpad[i]);
7373 # endif
7374 }
7375 #endif
7376 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7377 * outer CV (the one whose slab holds the pm op). The
7378 * inner CV (which holds expr) will be freed later, once
7379 * all the entries on the parse stack have been popped on
7380 * return from this function. Which is why its safe to
7381 * call op_free(expr) below.
7382 */
7383 LEAVE_SCOPE(floor);
7384 pm->op_pmflags &= ~PMf_HAS_CV;
7385 }
7386
7387 /* Skip compiling if parser found an error for this pattern */
7388 if (pm->op_pmflags & PMf_HAS_ERROR) {
7389 return o;
7390 }
7391
7392 PM_SETRE(pm,
7393 eng->op_comp
7394 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7395 rx_flags, pm->op_pmflags)
7396 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7397 rx_flags, pm->op_pmflags)
7398 );
7399 op_free(expr);
7400 }
7401 else {
7402 /* compile-time pattern that includes literal code blocks */
7403
7404 REGEXP* re;
7405
7406 /* Skip compiling if parser found an error for this pattern */
7407 if (pm->op_pmflags & PMf_HAS_ERROR) {
7408 return o;
7409 }
7410
7411 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7412 rx_flags,
7413 (pm->op_pmflags |
7414 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7415 );
7416 PM_SETRE(pm, re);
7417 if (pm->op_pmflags & PMf_HAS_CV) {
7418 CV *cv;
7419 /* this QR op (and the anon sub we embed it in) is never
7420 * actually executed. It's just a placeholder where we can
7421 * squirrel away expr in op_code_list without the peephole
7422 * optimiser etc processing it for a second time */
7423 OP *qr = newPMOP(OP_QR, 0);
7424 cPMOPx(qr)->op_code_list = expr;
7425
7426 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7427 SvREFCNT_inc_simple_void(PL_compcv);
7428 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7429 ReANY(re)->qr_anoncv = cv;
7430
7431 /* attach the anon CV to the pad so that
7432 * pad_fixup_inner_anons() can find it */
7433 (void)pad_add_anon(cv, o->op_type);
7434 SvREFCNT_inc_simple_void(cv);
7435 }
7436 else {
7437 pm->op_code_list = expr;
7438 }
7439 }
7440 }
7441 else {
7442 /* runtime pattern: build chain of regcomp etc ops */
7443 bool reglist;
7444 PADOFFSET cv_targ = 0;
7445
7446 reglist = isreg && expr->op_type == OP_LIST;
7447 if (reglist)
7448 op_null(expr);
7449
7450 if (has_code) {
7451 pm->op_code_list = expr;
7452 /* don't free op_code_list; its ops are embedded elsewhere too */
7453 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7454 }
7455
7456 if (is_split)
7457 /* make engine handle split ' ' specially */
7458 pm->op_pmflags |= PMf_SPLIT;
7459
7460 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7461 * to allow its op_next to be pointed past the regcomp and
7462 * preceding stacking ops;
7463 * OP_REGCRESET is there to reset taint before executing the
7464 * stacking ops */
7465 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7466 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7467
7468 if (pm->op_pmflags & PMf_HAS_CV) {
7469 /* we have a runtime qr with literal code. This means
7470 * that the qr// has been wrapped in a new CV, which
7471 * means that runtime consts, vars etc will have been compiled
7472 * against a new pad. So... we need to execute those ops
7473 * within the environment of the new CV. So wrap them in a call
7474 * to a new anon sub. i.e. for
7475 *
7476 * qr/a$b(?{...})/,
7477 *
7478 * we build an anon sub that looks like
7479 *
7480 * sub { "a", $b, '(?{...})' }
7481 *
7482 * and call it, passing the returned list to regcomp.
7483 * Or to put it another way, the list of ops that get executed
7484 * are:
7485 *
7486 * normal PMf_HAS_CV
7487 * ------ -------------------
7488 * pushmark (for regcomp)
7489 * pushmark (for entersub)
7490 * anoncode
7491 * entersub
7492 * regcreset regcreset
7493 * pushmark pushmark
7494 * const("a") const("a")
7495 * gvsv(b) gvsv(b)
7496 * const("(?{...})") const("(?{...})")
7497 * leavesub
7498 * regcomp regcomp
7499 */
7500
7501 SvREFCNT_inc_simple_void(PL_compcv);
7502 CvLVALUE_on(PL_compcv);
7503 /* these lines are just an unrolled newANONATTRSUB */
7504 expr = newSVOP(OP_ANONCODE, OPf_REF,
7505 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7506 cv_targ = expr->op_targ;
7507
7508 expr = list(op_force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
7509 }
7510
7511 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7512 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7513 | (reglist ? OPf_STACKED : 0);
7514 rcop->op_targ = cv_targ;
7515
7516 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
7517 if (PL_hints & HINT_RE_EVAL)
7518 S_set_haseval(aTHX);
7519
7520 /* establish postfix order */
7521 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7522 LINKLIST(expr);
7523 rcop->op_next = expr;
7524 cUNOPx(expr)->op_first->op_next = (OP*)rcop;
7525 }
7526 else {
7527 rcop->op_next = LINKLIST(expr);
7528 expr->op_next = (OP*)rcop;
7529 }
7530
7531 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7532 }
7533
7534 if (repl) {
7535 OP *curop = repl;
7536 bool konst;
7537 /* If we are looking at s//.../e with a single statement, get past
7538 the implicit do{}. */
7539 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7540 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7541 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7542 {
7543 OP *sib;
7544 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7545 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7546 && !OpHAS_SIBLING(sib))
7547 curop = sib;
7548 }
7549 if (curop->op_type == OP_CONST)
7550 konst = TRUE;
7551 else if (( (curop->op_type == OP_RV2SV ||
7552 curop->op_type == OP_RV2AV ||
7553 curop->op_type == OP_RV2HV ||
7554 curop->op_type == OP_RV2GV)
7555 && cUNOPx(curop)->op_first
7556 && cUNOPx(curop)->op_first->op_type == OP_GV )
7557 || curop->op_type == OP_PADSV
7558 || curop->op_type == OP_PADAV
7559 || curop->op_type == OP_PADHV
7560 || curop->op_type == OP_PADANY) {
7561 repl_has_vars = 1;
7562 konst = TRUE;
7563 }
7564 else konst = FALSE;
7565 if (konst
7566 && !(repl_has_vars
7567 && (!PM_GETRE(pm)
7568 || !RX_PRELEN(PM_GETRE(pm))
7569 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7570 {
7571 pm->op_pmflags |= PMf_CONST; /* const for long enough */
7572 op_prepend_elem(o->op_type, scalar(repl), o);
7573 }
7574 else {
7575 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7576 rcop->op_private = 1;
7577
7578 /* establish postfix order */
7579 rcop->op_next = LINKLIST(repl);
7580 repl->op_next = (OP*)rcop;
7581
7582 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7583 assert(!(pm->op_pmflags & PMf_ONCE));
7584 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7585 rcop->op_next = 0;
7586 }
7587 }
7588
7589 return (OP*)pm;
7590 }
7591
7592 /*
7593 =for apidoc newSVOP
7594
7595 Constructs, checks, and returns an op of any type that involves an
7596 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
7597 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
7598 takes ownership of one reference to it.
7599
7600 =cut
7601 */
7602
7603 OP *
Perl_newSVOP(pTHX_ I32 type,I32 flags,SV * sv)7604 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7605 {
7606 SVOP *svop;
7607
7608 PERL_ARGS_ASSERT_NEWSVOP;
7609
7610 /* OP_RUNCV is allowed specially so rpeep has room to convert it into an
7611 * OP_CONST */
7612 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7613 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7614 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7615 || type == OP_RUNCV
7616 || type == OP_CUSTOM);
7617
7618 NewOp(1101, svop, 1, SVOP);
7619 OpTYPE_set(svop, type);
7620 svop->op_sv = sv;
7621 svop->op_next = (OP*)svop;
7622 svop->op_flags = (U8)flags;
7623 svop->op_private = (U8)(0 | (flags >> 8));
7624 if (PL_opargs[type] & OA_RETSCALAR)
7625 scalar((OP*)svop);
7626 if (PL_opargs[type] & OA_TARGET)
7627 svop->op_targ = pad_alloc(type, SVs_PADTMP);
7628 return CHECKOP(type, svop);
7629 }
7630
7631 /*
7632 =for apidoc newDEFSVOP
7633
7634 Constructs and returns an op to access C<$_>.
7635
7636 =cut
7637 */
7638
7639 OP *
Perl_newDEFSVOP(pTHX)7640 Perl_newDEFSVOP(pTHX)
7641 {
7642 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7643 }
7644
7645 #ifdef USE_ITHREADS
7646
7647 /*
7648 =for apidoc newPADOP
7649
7650 Constructs, checks, and returns an op of any type that involves a
7651 reference to a pad element. C<type> is the opcode. C<flags> gives the
7652 eight bits of C<op_flags>. A pad slot is automatically allocated, and
7653 is populated with C<sv>; this function takes ownership of one reference
7654 to it.
7655
7656 This function only exists if Perl has been compiled to use ithreads.
7657
7658 =cut
7659 */
7660
7661 OP *
Perl_newPADOP(pTHX_ I32 type,I32 flags,SV * sv)7662 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7663 {
7664 PADOP *padop;
7665
7666 PERL_ARGS_ASSERT_NEWPADOP;
7667
7668 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7669 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7670 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7671 || type == OP_CUSTOM);
7672
7673 NewOp(1101, padop, 1, PADOP);
7674 OpTYPE_set(padop, type);
7675 padop->op_padix =
7676 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7677 SvREFCNT_dec(PAD_SVl(padop->op_padix));
7678 PAD_SETSV(padop->op_padix, sv);
7679 assert(sv);
7680 padop->op_next = (OP*)padop;
7681 padop->op_flags = (U8)flags;
7682 if (PL_opargs[type] & OA_RETSCALAR)
7683 scalar((OP*)padop);
7684 if (PL_opargs[type] & OA_TARGET)
7685 padop->op_targ = pad_alloc(type, SVs_PADTMP);
7686 return CHECKOP(type, padop);
7687 }
7688
7689 #endif /* USE_ITHREADS */
7690
7691 /*
7692 =for apidoc newGVOP
7693
7694 Constructs, checks, and returns an op of any type that involves an
7695 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
7696 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
7697 reference; calling this function does not transfer ownership of any
7698 reference to it.
7699
7700 =cut
7701 */
7702
7703 OP *
Perl_newGVOP(pTHX_ I32 type,I32 flags,GV * gv)7704 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7705 {
7706 PERL_ARGS_ASSERT_NEWGVOP;
7707
7708 #ifdef USE_ITHREADS
7709 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7710 #else
7711 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7712 #endif
7713 }
7714
7715 /*
7716 =for apidoc newPVOP
7717
7718 Constructs, checks, and returns an op of any type that involves an
7719 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
7720 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
7721 Depending on the op type, the memory referenced by C<pv> may be freed
7722 when the op is destroyed. If the op is of a freeing type, C<pv> must
7723 have been allocated using C<PerlMemShared_malloc>.
7724
7725 =cut
7726 */
7727
7728 OP *
Perl_newPVOP(pTHX_ I32 type,I32 flags,char * pv)7729 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7730 {
7731 const bool utf8 = cBOOL(flags & SVf_UTF8);
7732 PVOP *pvop;
7733
7734 flags &= ~SVf_UTF8;
7735
7736 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7737 || type == OP_CUSTOM
7738 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7739
7740 NewOp(1101, pvop, 1, PVOP);
7741 OpTYPE_set(pvop, type);
7742 pvop->op_pv = pv;
7743 pvop->op_next = (OP*)pvop;
7744 pvop->op_flags = (U8)flags;
7745 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7746 if (PL_opargs[type] & OA_RETSCALAR)
7747 scalar((OP*)pvop);
7748 if (PL_opargs[type] & OA_TARGET)
7749 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7750 return CHECKOP(type, pvop);
7751 }
7752
7753 void
Perl_package(pTHX_ OP * o)7754 Perl_package(pTHX_ OP *o)
7755 {
7756 SV *const sv = cSVOPo->op_sv;
7757
7758 PERL_ARGS_ASSERT_PACKAGE;
7759
7760 SAVEGENERICSV(PL_curstash);
7761 save_item(PL_curstname);
7762
7763 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7764
7765 sv_setsv(PL_curstname, sv);
7766
7767 PL_hints |= HINT_BLOCK_SCOPE;
7768 PL_parser->copline = NOLINE;
7769
7770 op_free(o);
7771 }
7772
7773 void
Perl_package_version(pTHX_ OP * v)7774 Perl_package_version( pTHX_ OP *v )
7775 {
7776 U32 savehints = PL_hints;
7777 PERL_ARGS_ASSERT_PACKAGE_VERSION;
7778 PL_hints &= ~HINT_STRICT_VARS;
7779 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7780 PL_hints = savehints;
7781 op_free(v);
7782 }
7783
7784 /* Extract the first two components of a "version" object as two 8bit integers
7785 * and return them packed into a single U16 in the format of PL_prevailing_version.
7786 * This function only ever has to cope with version objects already known
7787 * bounded by the current perl version, so we know its components will fit
7788 * (Up until we reach perl version 5.256 anyway) */
S_extract_shortver(pTHX_ SV * sv)7789 static U16 S_extract_shortver(pTHX_ SV *sv)
7790 {
7791 SV *rv;
7792 if(!SvRV(sv) || !SvOBJECT(rv = SvRV(sv)) || !sv_derived_from(sv, "version"))
7793 return 0;
7794
7795 AV *av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rv), "version", 0)));
7796
7797 U16 shortver = 0;
7798
7799 IV major = av_count(av) > 0 ? SvIV(*av_fetch(av, 0, false)) : 0;
7800 if(major > 255)
7801 shortver |= 255 << 8;
7802 else
7803 shortver |= major << 8;
7804
7805 IV minor = av_count(av) > 1 ? SvIV(*av_fetch(av, 1, false)) : 0;
7806 if(minor > 255)
7807 shortver |= 255;
7808 else
7809 shortver |= minor;
7810
7811 return shortver;
7812 }
7813 #define SHORTVER(maj,min) ((maj << 8) | min)
7814
7815 void
Perl_utilize(pTHX_ int aver,I32 floor,OP * version,OP * idop,OP * arg)7816 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7817 {
7818 OP *pack;
7819 OP *imop;
7820 OP *veop;
7821 SV *use_version = NULL;
7822
7823 PERL_ARGS_ASSERT_UTILIZE;
7824
7825 if (idop->op_type != OP_CONST)
7826 Perl_croak(aTHX_ "Module name must be constant");
7827
7828 veop = NULL;
7829
7830 if (version) {
7831 SV * const vesv = cSVOPx(version)->op_sv;
7832
7833 if (!arg && !SvNIOKp(vesv)) {
7834 arg = version;
7835 }
7836 else {
7837 OP *pack;
7838 SV *meth;
7839
7840 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7841 Perl_croak(aTHX_ "Version number must be a constant number");
7842
7843 /* Make copy of idop so we don't free it twice */
7844 pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(idop)->op_sv));
7845
7846 /* Fake up a method call to VERSION */
7847 meth = newSVpvs_share("VERSION");
7848 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED,
7849 op_append_elem(OP_LIST,
7850 op_prepend_elem(OP_LIST, pack, version),
7851 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7852 }
7853 }
7854
7855 /* Fake up an import/unimport */
7856 if (arg && arg->op_type == OP_STUB) {
7857 imop = arg; /* no import on explicit () */
7858 }
7859 else if (SvNIOKp(cSVOPx(idop)->op_sv)) {
7860 imop = NULL; /* use 5.0; */
7861 if (aver)
7862 use_version = cSVOPx(idop)->op_sv;
7863 else
7864 idop->op_private |= OPpCONST_NOVER;
7865 }
7866 else {
7867 SV *meth;
7868
7869 /* Make copy of idop so we don't free it twice */
7870 pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(idop)->op_sv));
7871
7872 /* Fake up a method call to import/unimport */
7873 meth = aver
7874 ? newSVpvs_share("import") : newSVpvs_share("unimport");
7875 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED,
7876 op_append_elem(OP_LIST,
7877 op_prepend_elem(OP_LIST, pack, arg),
7878 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7879 ));
7880 }
7881
7882 /* Fake up the BEGIN {}, which does its thing immediately. */
7883 newATTRSUB(floor,
7884 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7885 NULL,
7886 NULL,
7887 op_append_elem(OP_LINESEQ,
7888 op_append_elem(OP_LINESEQ,
7889 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7890 newSTATEOP(0, NULL, veop)),
7891 newSTATEOP(0, NULL, imop) ));
7892
7893 if (use_version) {
7894 /* Enable the
7895 * feature bundle that corresponds to the required version. */
7896 use_version = sv_2mortal(new_version(use_version));
7897 S_enable_feature_bundle(aTHX_ use_version);
7898
7899 U16 shortver = S_extract_shortver(aTHX_ use_version);
7900
7901 /* If a version >= 5.11.0 is requested, strictures are on by default! */
7902 if (shortver >= SHORTVER(5, 11)) {
7903 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7904 PL_hints |= HINT_STRICT_REFS;
7905 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7906 PL_hints |= HINT_STRICT_SUBS;
7907 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7908 PL_hints |= HINT_STRICT_VARS;
7909
7910 if (shortver >= SHORTVER(5, 35))
7911 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
7912 }
7913 /* otherwise they are off */
7914 else {
7915 if(PL_prevailing_version >= SHORTVER(5, 11))
7916 deprecate_fatal_in(WARN_DEPRECATED__VERSION_DOWNGRADE, "5.40",
7917 "Downgrading a use VERSION declaration to below v5.11");
7918
7919 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7920 PL_hints &= ~HINT_STRICT_REFS;
7921 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7922 PL_hints &= ~HINT_STRICT_SUBS;
7923 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7924 PL_hints &= ~HINT_STRICT_VARS;
7925 }
7926
7927 PL_prevailing_version = shortver;
7928 }
7929
7930 /* The "did you use incorrect case?" warning used to be here.
7931 * The problem is that on case-insensitive filesystems one
7932 * might get false positives for "use" (and "require"):
7933 * "use Strict" or "require CARP" will work. This causes
7934 * portability problems for the script: in case-strict
7935 * filesystems the script will stop working.
7936 *
7937 * The "incorrect case" warning checked whether "use Foo"
7938 * imported "Foo" to your namespace, but that is wrong, too:
7939 * there is no requirement nor promise in the language that
7940 * a Foo.pm should or would contain anything in package "Foo".
7941 *
7942 * There is very little Configure-wise that can be done, either:
7943 * the case-sensitivity of the build filesystem of Perl does not
7944 * help in guessing the case-sensitivity of the runtime environment.
7945 */
7946
7947 PL_hints |= HINT_BLOCK_SCOPE;
7948 PL_parser->copline = NOLINE;
7949 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7950 }
7951
7952 /*
7953 =for apidoc_section $embedding
7954
7955 =for apidoc load_module
7956 =for apidoc_item load_module_nocontext
7957
7958 These load the module whose name is pointed to by the string part of C<name>.
7959 Note that the actual module name, not its filename, should be given.
7960 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7961 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7962 trailing arguments can be used to specify arguments to the module's C<import()>
7963 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7964 on the flags. The flags argument is a bitwise-ORed collection of any of
7965 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7966 (or 0 for no flags).
7967
7968 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7969 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7970 the trailing optional arguments may be omitted entirely. Otherwise, if
7971 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7972 exactly one C<OP*>, containing the op tree that produces the relevant import
7973 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7974 will be used as import arguments; and the list must be terminated with C<(SV*)
7975 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7976 set, the trailing C<NULL> pointer is needed even if no import arguments are
7977 desired. The reference count for each specified C<SV*> argument is
7978 decremented. In addition, the C<name> argument is modified.
7979
7980 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7981 than C<use>.
7982
7983 C<load_module> and C<load_module_nocontext> have the same apparent signature,
7984 but the former hides the fact that it is accessing a thread context parameter.
7985 So use the latter when you get a compilation error about C<pTHX>.
7986
7987 =for apidoc Amnh||PERL_LOADMOD_DENY
7988 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
7989 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
7990
7991 =for apidoc vload_module
7992 Like C<L</load_module>> but the arguments are an encapsulated argument list.
7993
7994 =cut */
7995
7996 void
Perl_load_module(pTHX_ U32 flags,SV * name,SV * ver,...)7997 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7998 {
7999 va_list args;
8000
8001 PERL_ARGS_ASSERT_LOAD_MODULE;
8002
8003 va_start(args, ver);
8004 vload_module(flags, name, ver, &args);
8005 va_end(args);
8006 }
8007
8008 #ifdef MULTIPLICITY
8009 void
Perl_load_module_nocontext(U32 flags,SV * name,SV * ver,...)8010 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8011 {
8012 dTHX;
8013 va_list args;
8014 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8015 va_start(args, ver);
8016 vload_module(flags, name, ver, &args);
8017 va_end(args);
8018 }
8019 #endif
8020
8021 void
Perl_vload_module(pTHX_ U32 flags,SV * name,SV * ver,va_list * args)8022 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8023 {
8024 OP *veop, *imop;
8025 OP * modname;
8026 I32 floor;
8027
8028 PERL_ARGS_ASSERT_VLOAD_MODULE;
8029
8030 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8031 * that it has a PL_parser to play with while doing that, and also
8032 * that it doesn't mess with any existing parser, by creating a tmp
8033 * new parser with lex_start(). This won't actually be used for much,
8034 * since pp_require() will create another parser for the real work.
8035 * The ENTER/LEAVE pair protect callers from any side effects of use.
8036 *
8037 * start_subparse() creates a new PL_compcv. This means that any ops
8038 * allocated below will be allocated from that CV's op slab, and so
8039 * will be automatically freed if the utilise() fails
8040 */
8041
8042 ENTER;
8043 SAVEVPTR(PL_curcop);
8044 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8045 floor = start_subparse(FALSE, 0);
8046
8047 modname = newSVOP(OP_CONST, 0, name);
8048 modname->op_private |= OPpCONST_BARE;
8049 if (ver) {
8050 veop = newSVOP(OP_CONST, 0, ver);
8051 }
8052 else
8053 veop = NULL;
8054 if (flags & PERL_LOADMOD_NOIMPORT) {
8055 imop = sawparens(newNULLLIST());
8056 }
8057 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8058 imop = va_arg(*args, OP*);
8059 }
8060 else {
8061 SV *sv;
8062 imop = NULL;
8063 sv = va_arg(*args, SV*);
8064 while (sv) {
8065 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8066 sv = va_arg(*args, SV*);
8067 }
8068 }
8069
8070 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
8071 LEAVE;
8072 }
8073
8074 PERL_STATIC_INLINE OP *
S_new_entersubop(pTHX_ GV * gv,OP * arg)8075 S_new_entersubop(pTHX_ GV *gv, OP *arg)
8076 {
8077 return newUNOP(OP_ENTERSUB, OPf_STACKED,
8078 newLISTOP(OP_LIST, 0, arg,
8079 newUNOP(OP_RV2CV, 0,
8080 newGVOP(OP_GV, 0, gv))));
8081 }
8082
8083 OP *
Perl_dofile(pTHX_ OP * term,I32 force_builtin)8084 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
8085 {
8086 OP *doop;
8087 GV *gv;
8088
8089 PERL_ARGS_ASSERT_DOFILE;
8090
8091 if (!force_builtin && (gv = gv_override("do", 2))) {
8092 doop = S_new_entersubop(aTHX_ gv, term);
8093 }
8094 else {
8095 doop = newUNOP(OP_DOFILE, 0, scalar(term));
8096 }
8097 return doop;
8098 }
8099
8100 /*
8101 =for apidoc_section $optree_construction
8102
8103 =for apidoc newSLICEOP
8104
8105 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
8106 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
8107 be set automatically, and, shifted up eight bits, the eight bits of
8108 C<op_private>, except that the bit with value 1 or 2 is automatically
8109 set as required. C<listval> and C<subscript> supply the parameters of
8110 the slice; they are consumed by this function and become part of the
8111 constructed op tree.
8112
8113 =cut
8114 */
8115
8116 OP *
Perl_newSLICEOP(pTHX_ I32 flags,OP * subscript,OP * listval)8117 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
8118 {
8119 return newBINOP(OP_LSLICE, flags,
8120 list(op_force_list(subscript)),
8121 list(op_force_list(listval)));
8122 }
8123
8124 #define ASSIGN_SCALAR 0
8125 #define ASSIGN_LIST 1
8126 #define ASSIGN_REF 2
8127
8128 /* given the optree o on the LHS of an assignment, determine whether its:
8129 * ASSIGN_SCALAR $x = ...
8130 * ASSIGN_LIST ($x) = ...
8131 * ASSIGN_REF \$x = ...
8132 */
8133
8134 STATIC I32
S_assignment_type(pTHX_ const OP * o)8135 S_assignment_type(pTHX_ const OP *o)
8136 {
8137 unsigned type;
8138 U8 flags;
8139 U8 ret;
8140
8141 if (!o)
8142 return ASSIGN_LIST;
8143
8144 if (o->op_type == OP_SREFGEN)
8145 {
8146 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
8147 type = kid->op_type;
8148 flags = o->op_flags | kid->op_flags;
8149 if (!(flags & OPf_PARENS)
8150 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
8151 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
8152 return ASSIGN_REF;
8153 ret = ASSIGN_REF;
8154 } else {
8155 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
8156 o = cUNOPo->op_first;
8157 flags = o->op_flags;
8158 type = o->op_type;
8159 ret = ASSIGN_SCALAR;
8160 }
8161
8162 if (type == OP_COND_EXPR) {
8163 OP * const sib = OpSIBLING(cLOGOPo->op_first);
8164 const I32 t = assignment_type(sib);
8165 const I32 f = assignment_type(OpSIBLING(sib));
8166
8167 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
8168 return ASSIGN_LIST;
8169 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
8170 yyerror("Assignment to both a list and a scalar");
8171 return ASSIGN_SCALAR;
8172 }
8173
8174 if (type == OP_LIST &&
8175 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
8176 o->op_private & OPpLVAL_INTRO)
8177 return ret;
8178
8179 if (type == OP_LIST || flags & OPf_PARENS ||
8180 type == OP_RV2AV || type == OP_RV2HV ||
8181 type == OP_ASLICE || type == OP_HSLICE ||
8182 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
8183 return ASSIGN_LIST;
8184
8185 if (type == OP_PADAV || type == OP_PADHV)
8186 return ASSIGN_LIST;
8187
8188 if (type == OP_RV2SV)
8189 return ret;
8190
8191 return ret;
8192 }
8193
8194 static OP *
S_newONCEOP(pTHX_ OP * initop,OP * padop)8195 S_newONCEOP(pTHX_ OP *initop, OP *padop)
8196 {
8197 const PADOFFSET target = padop->op_targ;
8198 OP *const other = newOP(OP_PADSV,
8199 padop->op_flags
8200 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
8201 OP *const first = newOP(OP_NULL, 0);
8202 OP *const nullop = newCONDOP(0, first, initop, other);
8203 /* XXX targlex disabled for now; see ticket #124160
8204 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
8205 */
8206 OP *const condop = first->op_next;
8207
8208 OpTYPE_set(condop, OP_ONCE);
8209 other->op_targ = target;
8210 nullop->op_flags |= OPf_WANT_SCALAR;
8211
8212 /* Store the initializedness of state vars in a separate
8213 pad entry. */
8214 condop->op_targ =
8215 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
8216 /* hijacking PADSTALE for uninitialized state variables */
8217 SvPADSTALE_on(PAD_SVl(condop->op_targ));
8218
8219 return nullop;
8220 }
8221
8222 /*
8223 =for apidoc newARGDEFELEMOP
8224
8225 Constructs and returns a new C<OP_ARGDEFELEM> op which provides a defaulting
8226 expression given by C<expr> for the signature parameter at the index given
8227 by C<argindex>. The expression optree is consumed by this function and
8228 becomes part of the returned optree.
8229
8230 =cut
8231 */
8232
8233 OP *
Perl_newARGDEFELEMOP(pTHX_ I32 flags,OP * expr,I32 argindex)8234 Perl_newARGDEFELEMOP(pTHX_ I32 flags, OP *expr, I32 argindex)
8235 {
8236 PERL_ARGS_ASSERT_NEWARGDEFELEMOP;
8237
8238 OP *o = (OP *)alloc_LOGOP(OP_ARGDEFELEM, expr, LINKLIST(expr));
8239 o->op_flags |= (U8)(flags);
8240 o->op_private = 1 | (U8)(flags >> 8);
8241
8242 /* re-purpose op_targ to hold @_ index */
8243 o->op_targ = (PADOFFSET)(argindex);
8244
8245 return o;
8246 }
8247
8248 /*
8249 =for apidoc newASSIGNOP
8250
8251 Constructs, checks, and returns an assignment op. C<left> and C<right>
8252 supply the parameters of the assignment; they are consumed by this
8253 function and become part of the constructed op tree.
8254
8255 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
8256 a suitable conditional optree is constructed. If C<optype> is the opcode
8257 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
8258 performs the binary operation and assigns the result to the left argument.
8259 Either way, if C<optype> is non-zero then C<flags> has no effect.
8260
8261 If C<optype> is zero, then a plain scalar or list assignment is
8262 constructed. Which type of assignment it is is automatically determined.
8263 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8264 will be set automatically, and, shifted up eight bits, the eight bits
8265 of C<op_private>, except that the bit with value 1 or 2 is automatically
8266 set as required.
8267
8268 =cut
8269 */
8270
8271 OP *
Perl_newASSIGNOP(pTHX_ I32 flags,OP * left,I32 optype,OP * right)8272 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
8273 {
8274 OP *o;
8275 I32 assign_type;
8276
8277 switch (optype) {
8278 case 0: break;
8279 case OP_ANDASSIGN:
8280 case OP_ORASSIGN:
8281 case OP_DORASSIGN:
8282 right = scalar(right);
8283 return newLOGOP(optype, 0,
8284 op_lvalue(scalar(left), optype),
8285 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
8286 default:
8287 return newBINOP(optype, OPf_STACKED,
8288 op_lvalue(scalar(left), optype), scalar(right));
8289 }
8290
8291 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
8292 OP *state_var_op = NULL;
8293 static const char no_list_state[] = "Initialization of state variables"
8294 " in list currently forbidden";
8295 OP *curop;
8296
8297 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
8298 left->op_private &= ~ OPpSLICEWARNING;
8299
8300 PL_modcount = 0;
8301 left = op_lvalue(left, OP_AASSIGN);
8302 curop = list(op_force_list(left));
8303 o = newBINOP(OP_AASSIGN, flags, list(op_force_list(right)), curop);
8304 o->op_private = (U8)(0 | (flags >> 8));
8305
8306 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
8307 {
8308 OP *lop = cLISTOPx(left)->op_first, *vop, *eop;
8309 if (!(left->op_flags & OPf_PARENS) &&
8310 lop->op_type == OP_PUSHMARK &&
8311 (vop = OpSIBLING(lop)) &&
8312 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
8313 !(vop->op_flags & OPf_PARENS) &&
8314 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
8315 (OPpLVAL_INTRO|OPpPAD_STATE) &&
8316 (eop = OpSIBLING(vop)) &&
8317 eop->op_type == OP_ENTERSUB &&
8318 !OpHAS_SIBLING(eop)) {
8319 state_var_op = vop;
8320 } else {
8321 while (lop) {
8322 if ((lop->op_type == OP_PADSV ||
8323 lop->op_type == OP_PADAV ||
8324 lop->op_type == OP_PADHV ||
8325 lop->op_type == OP_PADANY)
8326 && (lop->op_private & OPpPAD_STATE)
8327 )
8328 yyerror(no_list_state);
8329 lop = OpSIBLING(lop);
8330 }
8331 }
8332 }
8333 else if ( (left->op_private & OPpLVAL_INTRO)
8334 && (left->op_private & OPpPAD_STATE)
8335 && ( left->op_type == OP_PADSV
8336 || left->op_type == OP_PADAV
8337 || left->op_type == OP_PADHV
8338 || left->op_type == OP_PADANY)
8339 ) {
8340 /* All single variable list context state assignments, hence
8341 state ($a) = ...
8342 (state $a) = ...
8343 state @a = ...
8344 state (@a) = ...
8345 (state @a) = ...
8346 state %a = ...
8347 state (%a) = ...
8348 (state %a) = ...
8349 */
8350 if (left->op_flags & OPf_PARENS)
8351 yyerror(no_list_state);
8352 else
8353 state_var_op = left;
8354 }
8355
8356 /* optimise @a = split(...) into:
8357 * @{expr}: split(..., @{expr}) (where @a is not flattened)
8358 * @a, my @a, local @a: split(...) (where @a is attached to
8359 * the split op itself)
8360 */
8361
8362 if ( right
8363 && right->op_type == OP_SPLIT
8364 /* don't do twice, e.g. @b = (@a = split) */
8365 && !(right->op_private & OPpSPLIT_ASSIGN))
8366 {
8367 OP *gvop = NULL;
8368
8369 if ( ( left->op_type == OP_RV2AV
8370 && (gvop=cUNOPx(left)->op_first)->op_type==OP_GV)
8371 || left->op_type == OP_PADAV)
8372 {
8373 /* @pkg or @lex or local @pkg' or 'my @lex' */
8374 OP *tmpop;
8375 if (gvop) {
8376 #ifdef USE_ITHREADS
8377 cPMOPx(right)->op_pmreplrootu.op_pmtargetoff
8378 = cPADOPx(gvop)->op_padix;
8379 cPADOPx(gvop)->op_padix = 0; /* steal it */
8380 #else
8381 cPMOPx(right)->op_pmreplrootu.op_pmtargetgv
8382 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8383 cSVOPx(gvop)->op_sv = NULL; /* steal it */
8384 #endif
8385 right->op_private |=
8386 left->op_private & OPpOUR_INTRO;
8387 }
8388 else {
8389 cPMOPx(right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8390 left->op_targ = 0; /* steal it */
8391 right->op_private |= OPpSPLIT_LEX;
8392 }
8393 right->op_private |= left->op_private & OPpLVAL_INTRO;
8394
8395 detach_split:
8396 tmpop = cUNOPo->op_first; /* to list (nulled) */
8397 tmpop = cUNOPx(tmpop)->op_first; /* to pushmark */
8398 assert(OpSIBLING(tmpop) == right);
8399 assert(!OpHAS_SIBLING(right));
8400 /* detach the split subtreee from the o tree,
8401 * then free the residual o tree */
8402 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8403 op_free(o); /* blow off assign */
8404 right->op_private |= OPpSPLIT_ASSIGN;
8405 right->op_flags &= ~OPf_WANT;
8406 /* "I don't know and I don't care." */
8407 return right;
8408 }
8409 else if (left->op_type == OP_RV2AV) {
8410 /* @{expr} */
8411
8412 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8413 assert(OpSIBLING(pushop) == left);
8414 /* Detach the array ... */
8415 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8416 /* ... and attach it to the split. */
8417 op_sibling_splice(right, cLISTOPx(right)->op_last,
8418 0, left);
8419 right->op_flags |= OPf_STACKED;
8420 /* Detach split and expunge aassign as above. */
8421 goto detach_split;
8422 }
8423 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8424 cLISTOPx(right)->op_last->op_type == OP_CONST)
8425 {
8426 /* convert split(...,0) to split(..., PL_modcount+1) */
8427 SV ** const svp =
8428 &cSVOPx(cLISTOPx(right)->op_last)->op_sv;
8429 SV * const sv = *svp;
8430 if (SvIOK(sv) && SvIVX(sv) == 0)
8431 {
8432 if (right->op_private & OPpSPLIT_IMPLIM) {
8433 /* our own SV, created in ck_split */
8434 SvREADONLY_off(sv);
8435 sv_setiv(sv, PL_modcount+1);
8436 }
8437 else {
8438 /* SV may belong to someone else */
8439 SvREFCNT_dec(sv);
8440 *svp = newSViv(PL_modcount+1);
8441 }
8442 }
8443 }
8444 }
8445
8446 if (state_var_op)
8447 o = S_newONCEOP(aTHX_ o, state_var_op);
8448 return o;
8449 }
8450 if (assign_type == ASSIGN_REF)
8451 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8452 if (!right)
8453 right = newOP(OP_UNDEF, 0);
8454 if (right->op_type == OP_READLINE) {
8455 right->op_flags |= OPf_STACKED;
8456 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8457 scalar(right));
8458 }
8459 else {
8460 o = newBINOP(OP_SASSIGN, flags,
8461 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8462 }
8463 return o;
8464 }
8465
8466 /*
8467 =for apidoc newSTATEOP
8468
8469 Constructs a state op (COP). The state op is normally a C<nextstate> op,
8470 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8471 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8472 If C<label> is non-null, it supplies the name of a label to attach to
8473 the state op; this function takes ownership of the memory pointed at by
8474 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
8475 for the state op.
8476
8477 If C<o> is null, the state op is returned. Otherwise the state op is
8478 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
8479 is consumed by this function and becomes part of the returned op tree.
8480
8481 =cut
8482 */
8483
8484 OP *
Perl_newSTATEOP(pTHX_ I32 flags,char * label,OP * o)8485 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8486 {
8487 const U32 seq = intro_my();
8488 const U32 utf8 = flags & SVf_UTF8;
8489 COP *cop;
8490
8491 assert(PL_parser);
8492 PL_parser->parsed_sub = 0;
8493
8494 flags &= ~SVf_UTF8;
8495
8496 NewOp(1101, cop, 1, COP);
8497 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8498 OpTYPE_set(cop, OP_DBSTATE);
8499 }
8500 else {
8501 OpTYPE_set(cop, OP_NEXTSTATE);
8502 }
8503 cop->op_flags = (U8)flags;
8504 CopHINTS_set(cop, PL_hints);
8505 #ifdef VMS
8506 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8507 #endif
8508 cop->op_next = (OP*)cop;
8509
8510 cop->cop_seq = seq;
8511 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8512 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8513 CopFEATURES_setfrom(cop, PL_curcop);
8514 if (label) {
8515 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8516
8517 PL_hints |= HINT_BLOCK_SCOPE;
8518 /* It seems that we need to defer freeing this pointer, as other parts
8519 of the grammar end up wanting to copy it after this op has been
8520 created. */
8521 SAVEFREEPV(label);
8522 }
8523
8524 if (PL_parser->preambling != NOLINE) {
8525 CopLINE_set(cop, PL_parser->preambling);
8526 PL_parser->copline = NOLINE;
8527 }
8528 else if (PL_parser->copline == NOLINE)
8529 CopLINE_set(cop, CopLINE(PL_curcop));
8530 else {
8531 CopLINE_set(cop, PL_parser->copline);
8532 PL_parser->copline = NOLINE;
8533 }
8534 #ifdef USE_ITHREADS
8535 CopFILE_copy(cop, PL_curcop);
8536 #else
8537 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8538 #endif
8539 CopSTASH_set(cop, PL_curstash);
8540
8541 if (cop->op_type == OP_DBSTATE) {
8542 /* this line can have a breakpoint - store the cop in IV */
8543 AV *av = CopFILEAVx(PL_curcop);
8544 if (av) {
8545 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8546 if (svp && *svp != &PL_sv_undef ) {
8547 (void)SvIOK_on(*svp);
8548 SvIV_set(*svp, PTR2IV(cop));
8549 }
8550 }
8551 }
8552
8553 if (flags & OPf_SPECIAL)
8554 op_null((OP*)cop);
8555 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8556 }
8557
8558 /*
8559 =for apidoc newLOGOP
8560
8561 Constructs, checks, and returns a logical (flow control) op. C<type>
8562 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
8563 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8564 the eight bits of C<op_private>, except that the bit with value 1 is
8565 automatically set. C<first> supplies the expression controlling the
8566 flow, and C<other> supplies the side (alternate) chain of ops; they are
8567 consumed by this function and become part of the constructed op tree.
8568
8569 =cut
8570 */
8571
8572 OP *
Perl_newLOGOP(pTHX_ I32 type,I32 flags,OP * first,OP * other)8573 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8574 {
8575 PERL_ARGS_ASSERT_NEWLOGOP;
8576
8577 return new_logop(type, flags, &first, &other);
8578 }
8579
8580
8581 /* See if the optree o contains a single OP_CONST (plus possibly
8582 * surrounding enter/nextstate/null etc). If so, return it, else return
8583 * NULL.
8584 */
8585
8586 STATIC OP *
S_search_const(pTHX_ OP * o)8587 S_search_const(pTHX_ OP *o)
8588 {
8589 PERL_ARGS_ASSERT_SEARCH_CONST;
8590
8591 redo:
8592 switch (o->op_type) {
8593 case OP_CONST:
8594 return o;
8595 case OP_NULL:
8596 if (o->op_flags & OPf_KIDS) {
8597 o = cUNOPo->op_first;
8598 goto redo;
8599 }
8600 break;
8601 case OP_LEAVE:
8602 case OP_SCOPE:
8603 case OP_LINESEQ:
8604 {
8605 OP *kid;
8606 if (!(o->op_flags & OPf_KIDS))
8607 return NULL;
8608 kid = cLISTOPo->op_first;
8609
8610 do {
8611 switch (kid->op_type) {
8612 case OP_ENTER:
8613 case OP_NULL:
8614 case OP_NEXTSTATE:
8615 kid = OpSIBLING(kid);
8616 break;
8617 default:
8618 if (kid != cLISTOPo->op_last)
8619 return NULL;
8620 goto last;
8621 }
8622 } while (kid);
8623
8624 if (!kid)
8625 kid = cLISTOPo->op_last;
8626 last:
8627 o = kid;
8628 goto redo;
8629 }
8630 }
8631
8632 return NULL;
8633 }
8634
8635
8636 STATIC OP *
S_new_logop(pTHX_ I32 type,I32 flags,OP ** firstp,OP ** otherp)8637 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8638 {
8639 LOGOP *logop;
8640 OP *o;
8641 OP *first;
8642 OP *other;
8643 OP *cstop = NULL;
8644 int prepend_not = 0;
8645
8646 PERL_ARGS_ASSERT_NEW_LOGOP;
8647
8648 first = *firstp;
8649 other = *otherp;
8650
8651 /* [perl #59802]: Warn about things like "return $a or $b", which
8652 is parsed as "(return $a) or $b" rather than "return ($a or
8653 $b)". NB: This also applies to xor, which is why we do it
8654 here.
8655 */
8656 switch (first->op_type) {
8657 case OP_NEXT:
8658 case OP_LAST:
8659 case OP_REDO:
8660 /* XXX: Perhaps we should emit a stronger warning for these.
8661 Even with the high-precedence operator they don't seem to do
8662 anything sensible.
8663
8664 But until we do, fall through here.
8665 */
8666 case OP_RETURN:
8667 case OP_EXIT:
8668 case OP_DIE:
8669 case OP_GOTO:
8670 /* XXX: Currently we allow people to "shoot themselves in the
8671 foot" by explicitly writing "(return $a) or $b".
8672
8673 Warn unless we are looking at the result from folding or if
8674 the programmer explicitly grouped the operators like this.
8675 The former can occur with e.g.
8676
8677 use constant FEATURE => ( $] >= ... );
8678 sub { not FEATURE and return or do_stuff(); }
8679 */
8680 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8681 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8682 "Possible precedence issue with control flow operator");
8683 /* XXX: Should we optimze this to "return $a;" (i.e. remove
8684 the "or $b" part)?
8685 */
8686 break;
8687 }
8688
8689 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8690 return newBINOP(type, flags, scalar(first), scalar(other));
8691
8692 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8693 || type == OP_CUSTOM);
8694
8695 scalarboolean(first);
8696
8697 /* search for a constant op that could let us fold the test */
8698 if ((cstop = search_const(first))) {
8699 if (cstop->op_private & OPpCONST_STRICT)
8700 no_bareword_allowed(cstop);
8701 else if ((cstop->op_private & OPpCONST_BARE))
8702 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8703 if ((type == OP_AND && SvTRUE(cSVOPx(cstop)->op_sv)) ||
8704 (type == OP_OR && !SvTRUE(cSVOPx(cstop)->op_sv)) ||
8705 (type == OP_DOR && !SvOK(cSVOPx(cstop)->op_sv))) {
8706 /* Elide the (constant) lhs, since it can't affect the outcome */
8707 *firstp = NULL;
8708 if (other->op_type == OP_CONST)
8709 other->op_private |= OPpCONST_SHORTCIRCUIT;
8710 op_free(first);
8711 if (other->op_type == OP_LEAVE)
8712 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8713 else if (other->op_type == OP_MATCH
8714 || other->op_type == OP_SUBST
8715 || other->op_type == OP_TRANSR
8716 || other->op_type == OP_TRANS)
8717 /* Mark the op as being unbindable with =~ */
8718 other->op_flags |= OPf_SPECIAL;
8719
8720 other->op_folded = 1;
8721 return other;
8722 }
8723 else {
8724 /* Elide the rhs, since the outcome is entirely determined by
8725 * the (constant) lhs */
8726
8727 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8728 const OP *o2 = other;
8729 if ( ! (o2->op_type == OP_LIST
8730 && (( o2 = cUNOPx(o2)->op_first))
8731 && o2->op_type == OP_PUSHMARK
8732 && (( o2 = OpSIBLING(o2))) )
8733 )
8734 o2 = other;
8735 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8736 || o2->op_type == OP_PADHV)
8737 && o2->op_private & OPpLVAL_INTRO
8738 && !(o2->op_private & OPpPAD_STATE))
8739 {
8740 Perl_croak(aTHX_ "This use of my() in false conditional is "
8741 "no longer allowed");
8742 }
8743
8744 *otherp = NULL;
8745 if (cstop->op_type == OP_CONST)
8746 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8747 op_free(other);
8748 return first;
8749 }
8750 }
8751 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8752 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8753 {
8754 const OP * const k1 = cUNOPx(first)->op_first;
8755 const OP * const k2 = OpSIBLING(k1);
8756 OPCODE warnop = 0;
8757 switch (first->op_type)
8758 {
8759 case OP_NULL:
8760 if (k2 && k2->op_type == OP_READLINE
8761 && (k2->op_flags & OPf_STACKED)
8762 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8763 {
8764 warnop = k2->op_type;
8765 }
8766 break;
8767
8768 case OP_SASSIGN:
8769 if (k1->op_type == OP_READDIR
8770 || k1->op_type == OP_GLOB
8771 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8772 || k1->op_type == OP_EACH
8773 || k1->op_type == OP_AEACH)
8774 {
8775 warnop = ((k1->op_type == OP_NULL)
8776 ? (OPCODE)k1->op_targ : k1->op_type);
8777 }
8778 break;
8779 }
8780 if (warnop) {
8781 const line_t oldline = CopLINE(PL_curcop);
8782 /* This ensures that warnings are reported at the first line
8783 of the construction, not the last. */
8784 CopLINE_set(PL_curcop, PL_parser->copline);
8785 Perl_warner(aTHX_ packWARN(WARN_MISC),
8786 "Value of %s%s can be \"0\"; test with defined()",
8787 PL_op_desc[warnop],
8788 ((warnop == OP_READLINE || warnop == OP_GLOB)
8789 ? " construct" : "() operator"));
8790 CopLINE_set(PL_curcop, oldline);
8791 }
8792 }
8793
8794 /* optimize AND and OR ops that have NOTs as children */
8795 if (first->op_type == OP_NOT
8796 && (first->op_flags & OPf_KIDS)
8797 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8798 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8799 ) {
8800 if (type == OP_AND || type == OP_OR) {
8801 if (type == OP_AND)
8802 type = OP_OR;
8803 else
8804 type = OP_AND;
8805 op_null(first);
8806 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8807 op_null(other);
8808 prepend_not = 1; /* prepend a NOT op later */
8809 }
8810 }
8811 }
8812
8813 logop = alloc_LOGOP(type, first, LINKLIST(other));
8814 logop->op_flags |= (U8)flags;
8815 logop->op_private = (U8)(1 | (flags >> 8));
8816
8817 /* establish postfix order */
8818 logop->op_next = LINKLIST(first);
8819 first->op_next = (OP*)logop;
8820 assert(!OpHAS_SIBLING(first));
8821 op_sibling_splice((OP*)logop, first, 0, other);
8822
8823 CHECKOP(type,logop);
8824
8825 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8826 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8827 (OP*)logop);
8828 other->op_next = o;
8829
8830 return o;
8831 }
8832
8833 /*
8834 =for apidoc newCONDOP
8835
8836 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8837 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8838 will be set automatically, and, shifted up eight bits, the eight bits of
8839 C<op_private>, except that the bit with value 1 is automatically set.
8840 C<first> supplies the expression selecting between the two branches,
8841 and C<trueop> and C<falseop> supply the branches; they are consumed by
8842 this function and become part of the constructed op tree.
8843
8844 =cut
8845 */
8846
8847 OP *
Perl_newCONDOP(pTHX_ I32 flags,OP * first,OP * trueop,OP * falseop)8848 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8849 {
8850 LOGOP *logop;
8851 OP *start;
8852 OP *o;
8853 OP *cstop;
8854
8855 PERL_ARGS_ASSERT_NEWCONDOP;
8856
8857 if (!falseop)
8858 return newLOGOP(OP_AND, 0, first, trueop);
8859 if (!trueop)
8860 return newLOGOP(OP_OR, 0, first, falseop);
8861
8862 scalarboolean(first);
8863 if ((cstop = search_const(first))) {
8864 /* Left or right arm of the conditional? */
8865 const bool left = SvTRUE(cSVOPx(cstop)->op_sv);
8866 OP *live = left ? trueop : falseop;
8867 OP *const dead = left ? falseop : trueop;
8868 if (cstop->op_private & OPpCONST_BARE &&
8869 cstop->op_private & OPpCONST_STRICT) {
8870 no_bareword_allowed(cstop);
8871 }
8872 op_free(first);
8873 op_free(dead);
8874 if (live->op_type == OP_LEAVE)
8875 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8876 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8877 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8878 /* Mark the op as being unbindable with =~ */
8879 live->op_flags |= OPf_SPECIAL;
8880 live->op_folded = 1;
8881 return live;
8882 }
8883 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8884 logop->op_flags |= (U8)flags;
8885 logop->op_private = (U8)(1 | (flags >> 8));
8886 logop->op_next = LINKLIST(falseop);
8887
8888 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8889 logop);
8890
8891 /* establish postfix order */
8892 start = LINKLIST(first);
8893 first->op_next = (OP*)logop;
8894
8895 /* make first, trueop, falseop siblings */
8896 op_sibling_splice((OP*)logop, first, 0, trueop);
8897 op_sibling_splice((OP*)logop, trueop, 0, falseop);
8898
8899 o = newUNOP(OP_NULL, 0, (OP*)logop);
8900
8901 trueop->op_next = falseop->op_next = o;
8902
8903 o->op_next = start;
8904 return o;
8905 }
8906
8907 /*
8908 =for apidoc newTRYCATCHOP
8909
8910 Constructs and returns a conditional execution statement that implements
8911 the C<try>/C<catch> semantics. First the op tree in C<tryblock> is executed,
8912 inside a context that traps exceptions. If an exception occurs then the
8913 optree in C<catchblock> is executed, with the trapped exception set into the
8914 lexical variable given by C<catchvar> (which must be an op of type
8915 C<OP_PADSV>). All the optrees are consumed by this function and become part
8916 of the returned op tree.
8917
8918 The C<flags> argument is currently ignored.
8919
8920 =cut
8921 */
8922
8923 OP *
Perl_newTRYCATCHOP(pTHX_ I32 flags,OP * tryblock,OP * catchvar,OP * catchblock)8924 Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock)
8925 {
8926 OP *o, *catchop;
8927
8928 PERL_ARGS_ASSERT_NEWTRYCATCHOP;
8929 assert(catchvar->op_type == OP_PADSV);
8930
8931 PERL_UNUSED_ARG(flags);
8932
8933 /* The returned optree is shaped as:
8934 * LISTOP leavetrycatch
8935 * LOGOP entertrycatch
8936 * LISTOP poptry
8937 * $tryblock here
8938 * LOGOP catch
8939 * $catchblock here
8940 */
8941
8942 if(tryblock->op_type != OP_LINESEQ)
8943 tryblock = op_convert_list(OP_LINESEQ, 0, tryblock);
8944 OpTYPE_set(tryblock, OP_POPTRY);
8945
8946 /* Manually construct a naked LOGOP.
8947 * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL)
8948 * containing the LOGOP we wanted as its op_first */
8949 catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock);
8950 OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock);
8951 OpLASTSIB_set(catchblock, catchop);
8952
8953 /* Inject the catchvar's pad offset into the OP_CATCH targ */
8954 cLOGOPx(catchop)->op_targ = catchvar->op_targ;
8955 op_free(catchvar);
8956
8957 /* Build the optree structure */
8958 o = newLISTOP(OP_LIST, 0, tryblock, catchop);
8959 o = op_convert_list(OP_ENTERTRYCATCH, 0, o);
8960
8961 return o;
8962 }
8963
8964 /*
8965 =for apidoc newRANGE
8966
8967 Constructs and returns a C<range> op, with subordinate C<flip> and
8968 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
8969 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8970 for both the C<flip> and C<range> ops, except that the bit with value
8971 1 is automatically set. C<left> and C<right> supply the expressions
8972 controlling the endpoints of the range; they are consumed by this function
8973 and become part of the constructed op tree.
8974
8975 =cut
8976 */
8977
8978 OP *
Perl_newRANGE(pTHX_ I32 flags,OP * left,OP * right)8979 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8980 {
8981 LOGOP *range;
8982 OP *flip;
8983 OP *flop;
8984 OP *leftstart;
8985 OP *o;
8986
8987 PERL_ARGS_ASSERT_NEWRANGE;
8988
8989 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8990 range->op_flags = OPf_KIDS;
8991 leftstart = LINKLIST(left);
8992 range->op_private = (U8)(1 | (flags >> 8));
8993
8994 /* make left and right siblings */
8995 op_sibling_splice((OP*)range, left, 0, right);
8996
8997 range->op_next = (OP*)range;
8998 flip = newUNOP(OP_FLIP, flags, (OP*)range);
8999 flop = newUNOP(OP_FLOP, 0, flip);
9000 o = newUNOP(OP_NULL, 0, flop);
9001 LINKLIST(flop);
9002 range->op_next = leftstart;
9003
9004 left->op_next = flip;
9005 right->op_next = flop;
9006
9007 range->op_targ =
9008 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9009 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9010 flip->op_targ =
9011 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9012 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9013 SvPADTMP_on(PAD_SV(flip->op_targ));
9014
9015 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9016 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9017
9018 /* check barewords before they might be optimized away */
9019 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9020 no_bareword_allowed(left);
9021 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9022 no_bareword_allowed(right);
9023
9024 flip->op_next = o;
9025 if (!flip->op_private || !flop->op_private)
9026 LINKLIST(o); /* blow off optimizer unless constant */
9027
9028 return o;
9029 }
9030
9031 /*
9032 =for apidoc newLOOPOP
9033
9034 Constructs, checks, and returns an op tree expressing a loop. This is
9035 only a loop in the control flow through the op tree; it does not have
9036 the heavyweight loop structure that allows exiting the loop by C<last>
9037 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
9038 top-level op, except that some bits will be set automatically as required.
9039 C<expr> supplies the expression controlling loop iteration, and C<block>
9040 supplies the body of the loop; they are consumed by this function and
9041 become part of the constructed op tree. C<debuggable> is currently
9042 unused and should always be 1.
9043
9044 =cut
9045 */
9046
9047 OP *
Perl_newLOOPOP(pTHX_ I32 flags,I32 debuggable,OP * expr,OP * block)9048 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9049 {
9050 PERL_ARGS_ASSERT_NEWLOOPOP;
9051
9052 OP* listop;
9053 OP* o;
9054 const bool once = block && block->op_flags & OPf_SPECIAL &&
9055 block->op_type == OP_NULL;
9056
9057 PERL_UNUSED_ARG(debuggable);
9058
9059 if (once && (
9060 (expr->op_type == OP_CONST && !SvTRUE(cSVOPx(expr)->op_sv))
9061 || ( expr->op_type == OP_NOT
9062 && cUNOPx(expr)->op_first->op_type == OP_CONST
9063 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9064 )
9065 ))
9066 /* Return the block now, so that S_new_logop does not try to
9067 fold it away. */
9068 {
9069 op_free(expr);
9070 return block; /* do {} while 0 does once */
9071 }
9072
9073 if (expr->op_type == OP_READLINE
9074 || expr->op_type == OP_READDIR
9075 || expr->op_type == OP_GLOB
9076 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9077 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9078 expr = newUNOP(OP_DEFINED, 0,
9079 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9080 } else if (expr->op_flags & OPf_KIDS) {
9081 const OP * const k1 = cUNOPx(expr)->op_first;
9082 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9083 switch (expr->op_type) {
9084 case OP_NULL:
9085 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9086 && (k2->op_flags & OPf_STACKED)
9087 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9088 expr = newUNOP(OP_DEFINED, 0, expr);
9089 break;
9090
9091 case OP_SASSIGN:
9092 if (k1 && (k1->op_type == OP_READDIR
9093 || k1->op_type == OP_GLOB
9094 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9095 || k1->op_type == OP_EACH
9096 || k1->op_type == OP_AEACH))
9097 expr = newUNOP(OP_DEFINED, 0, expr);
9098 break;
9099 }
9100 }
9101
9102 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9103 * op, in listop. This is wrong. [perl #27024] */
9104 if (!block)
9105 block = newOP(OP_NULL, 0);
9106 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9107 o = new_logop(OP_AND, 0, &expr, &listop);
9108
9109 if (once) {
9110 ASSUME(listop);
9111 }
9112
9113 if (listop)
9114 cLISTOPx(listop)->op_last->op_next = LINKLIST(o);
9115
9116 if (once && o != listop)
9117 {
9118 assert(cUNOPo->op_first->op_type == OP_AND
9119 || cUNOPo->op_first->op_type == OP_OR);
9120 o->op_next = cLOGOPx(cUNOPo->op_first)->op_other;
9121 }
9122
9123 if (o == listop)
9124 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
9125
9126 o->op_flags |= flags;
9127 o = op_scope(o);
9128 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9129 return o;
9130 }
9131
9132 /*
9133 =for apidoc newWHILEOP
9134
9135 Constructs, checks, and returns an op tree expressing a C<while> loop.
9136 This is a heavyweight loop, with structure that allows exiting the loop
9137 by C<last> and suchlike.
9138
9139 C<loop> is an optional preconstructed C<enterloop> op to use in the
9140 loop; if it is null then a suitable op will be constructed automatically.
9141 C<expr> supplies the loop's controlling expression. C<block> supplies the
9142 main body of the loop, and C<cont> optionally supplies a C<continue> block
9143 that operates as a second half of the body. All of these optree inputs
9144 are consumed by this function and become part of the constructed op tree.
9145
9146 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9147 op and, shifted up eight bits, the eight bits of C<op_private> for
9148 the C<leaveloop> op, except that (in both cases) some bits will be set
9149 automatically. C<debuggable> is currently unused and should always be 1.
9150 C<has_my> can be supplied as true to force the
9151 loop body to be enclosed in its own scope.
9152
9153 =cut
9154 */
9155
9156 OP *
Perl_newWHILEOP(pTHX_ I32 flags,I32 debuggable,LOOP * loop,OP * expr,OP * block,OP * cont,I32 has_my)9157 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9158 OP *expr, OP *block, OP *cont, I32 has_my)
9159 {
9160 OP *redo;
9161 OP *next = NULL;
9162 OP *listop;
9163 OP *o;
9164 U8 loopflags = 0;
9165
9166 PERL_UNUSED_ARG(debuggable);
9167
9168 if (expr) {
9169 if (expr->op_type == OP_READLINE
9170 || expr->op_type == OP_READDIR
9171 || expr->op_type == OP_GLOB
9172 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9173 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9174 expr = newUNOP(OP_DEFINED, 0,
9175 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9176 } else if (expr->op_flags & OPf_KIDS) {
9177 const OP * const k1 = cUNOPx(expr)->op_first;
9178 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
9179 switch (expr->op_type) {
9180 case OP_NULL:
9181 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9182 && (k2->op_flags & OPf_STACKED)
9183 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9184 expr = newUNOP(OP_DEFINED, 0, expr);
9185 break;
9186
9187 case OP_SASSIGN:
9188 if (k1 && (k1->op_type == OP_READDIR
9189 || k1->op_type == OP_GLOB
9190 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9191 || k1->op_type == OP_EACH
9192 || k1->op_type == OP_AEACH))
9193 expr = newUNOP(OP_DEFINED, 0, expr);
9194 break;
9195 }
9196 }
9197 }
9198
9199 if (!block)
9200 block = newOP(OP_NULL, 0);
9201 else if (cont || has_my) {
9202 block = op_scope(block);
9203 }
9204
9205 if (cont) {
9206 next = LINKLIST(cont);
9207 }
9208 if (expr) {
9209 OP * const unstack = newOP(OP_UNSTACK, 0);
9210 if (!next)
9211 next = unstack;
9212 cont = op_append_elem(OP_LINESEQ, cont, unstack);
9213 }
9214
9215 assert(block);
9216 listop = op_append_list(OP_LINESEQ, block, cont);
9217 assert(listop);
9218 redo = LINKLIST(listop);
9219
9220 if (expr) {
9221 scalar(listop);
9222 o = new_logop(OP_AND, 0, &expr, &listop);
9223 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
9224 op_free((OP*)loop);
9225 return expr; /* listop already freed by new_logop */
9226 }
9227 if (listop)
9228 cLISTOPx(listop)->op_last->op_next =
9229 (o == listop ? redo : LINKLIST(o));
9230 }
9231 else
9232 o = listop;
9233
9234 if (!loop) {
9235 NewOp(1101,loop,1,LOOP);
9236 OpTYPE_set(loop, OP_ENTERLOOP);
9237 loop->op_private = 0;
9238 loop->op_next = (OP*)loop;
9239 }
9240
9241 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
9242
9243 loop->op_redoop = redo;
9244 loop->op_lastop = o;
9245 o->op_private |= loopflags;
9246
9247 if (next)
9248 loop->op_nextop = next;
9249 else
9250 loop->op_nextop = o;
9251
9252 o->op_flags |= flags;
9253 o->op_private |= (flags >> 8);
9254 return o;
9255 }
9256
9257 /*
9258 =for apidoc newFOROP
9259
9260 Constructs, checks, and returns an op tree expressing a C<foreach>
9261 loop (iteration through a list of values). This is a heavyweight loop,
9262 with structure that allows exiting the loop by C<last> and suchlike.
9263
9264 C<sv> optionally supplies the variable(s) that will be aliased to each
9265 item in turn; if null, it defaults to C<$_>.
9266 C<expr> supplies the list of values to iterate over. C<block> supplies
9267 the main body of the loop, and C<cont> optionally supplies a C<continue>
9268 block that operates as a second half of the body. All of these optree
9269 inputs are consumed by this function and become part of the constructed
9270 op tree.
9271
9272 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9273 op and, shifted up eight bits, the eight bits of C<op_private> for
9274 the C<leaveloop> op, except that (in both cases) some bits will be set
9275 automatically.
9276
9277 =cut
9278 */
9279
9280 OP *
Perl_newFOROP(pTHX_ I32 flags,OP * sv,OP * expr,OP * block,OP * cont)9281 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
9282 {
9283 LOOP *loop;
9284 OP *iter;
9285 PADOFFSET padoff = 0;
9286 PADOFFSET how_many_more = 0;
9287 I32 iterflags = 0;
9288 I32 iterpflags = 0;
9289 bool parens = 0;
9290
9291 PERL_ARGS_ASSERT_NEWFOROP;
9292
9293 if (sv) {
9294 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
9295 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
9296 OpTYPE_set(sv, OP_RV2GV);
9297
9298 /* The op_type check is needed to prevent a possible segfault
9299 * if the loop variable is undeclared and 'strict vars' is in
9300 * effect. This is illegal but is nonetheless parsed, so we
9301 * may reach this point with an OP_CONST where we're expecting
9302 * an OP_GV.
9303 */
9304 if (cUNOPx(sv)->op_first->op_type == OP_GV
9305 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
9306 iterpflags |= OPpITER_DEF;
9307 }
9308 else if (sv->op_type == OP_PADSV) { /* private variable */
9309 if (sv->op_flags & OPf_PARENS) {
9310 /* handle degenerate 1-var form of "for my ($x, ...)" */
9311 sv->op_private |= OPpLVAL_INTRO;
9312 parens = 1;
9313 }
9314 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
9315 padoff = sv->op_targ;
9316 sv->op_targ = 0;
9317 op_free(sv);
9318 sv = NULL;
9319 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9320 }
9321 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
9322 NOOP;
9323 else if (sv->op_type == OP_LIST) {
9324 LISTOP *list = cLISTOPx(sv);
9325 OP *pushmark = list->op_first;
9326 OP *first_padsv;
9327 UNOP *padsv;
9328 PADOFFSET i;
9329
9330 iterpflags = OPpLVAL_INTRO; /* for my ($k, $v) () */
9331 parens = 1;
9332
9333 if (!pushmark || pushmark->op_type != OP_PUSHMARK) {
9334 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting pushmark",
9335 pushmark ? PL_op_desc[pushmark->op_type] : "NULL");
9336 }
9337 first_padsv = OpSIBLING(pushmark);
9338 if (!first_padsv || first_padsv->op_type != OP_PADSV) {
9339 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting padsv",
9340 first_padsv ? PL_op_desc[first_padsv->op_type] : "NULL");
9341 }
9342 padoff = first_padsv->op_targ;
9343
9344 /* There should be at least one more PADSV to find, and the ops
9345 should have consecutive values in targ: */
9346 padsv = cUNOPx(OpSIBLING(first_padsv));
9347 do {
9348 if (!padsv || padsv->op_type != OP_PADSV) {
9349 Perl_croak(aTHX_ "panic: newFORLOOP, found %s at %zd, expecting padsv",
9350 padsv ? PL_op_desc[padsv->op_type] : "NULL",
9351 how_many_more);
9352 }
9353 ++how_many_more;
9354 if (padsv->op_targ != padoff + how_many_more) {
9355 Perl_croak(aTHX_ "panic: newFORLOOP, padsv at %zd targ is %zd, not %zd",
9356 how_many_more, padsv->op_targ, padoff + how_many_more);
9357 }
9358
9359 padsv = cUNOPx(OpSIBLING(padsv));
9360 } while (padsv);
9361
9362 /* OK, this optree has the shape that we expected. So now *we*
9363 "claim" the Pad slots: */
9364 first_padsv->op_targ = 0;
9365 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9366
9367 i = padoff;
9368
9369 padsv = cUNOPx(OpSIBLING(first_padsv));
9370 do {
9371 ++i;
9372 padsv->op_targ = 0;
9373 PAD_COMPNAME_GEN_set(i, PERL_INT_MAX);
9374
9375 padsv = cUNOPx(OpSIBLING(padsv));
9376 } while (padsv);
9377
9378 op_free(sv);
9379 sv = NULL;
9380 }
9381 else
9382 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
9383 if (padoff) {
9384 PADNAME * const pn = PAD_COMPNAME(padoff);
9385 const char * const name = PadnamePV(pn);
9386
9387 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
9388 iterpflags |= OPpITER_DEF;
9389 }
9390 }
9391 else {
9392 sv = newGVOP(OP_GV, 0, PL_defgv);
9393 iterpflags |= OPpITER_DEF;
9394 }
9395
9396 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
9397 expr = op_lvalue(op_force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
9398 iterflags |= OPf_STACKED;
9399 }
9400 else if (expr->op_type == OP_NULL &&
9401 (expr->op_flags & OPf_KIDS) &&
9402 cBINOPx(expr)->op_first->op_type == OP_FLOP)
9403 {
9404 /* Basically turn for($x..$y) into the same as for($x,$y), but we
9405 * set the STACKED flag to indicate that these values are to be
9406 * treated as min/max values by 'pp_enteriter'.
9407 */
9408 const UNOP* const flip = cUNOPx(cUNOPx(cBINOPx(expr)->op_first)->op_first);
9409 LOGOP* const range = cLOGOPx(flip->op_first);
9410 OP* const left = range->op_first;
9411 OP* const right = OpSIBLING(left);
9412 LISTOP* listop;
9413
9414 range->op_flags &= ~OPf_KIDS;
9415 /* detach range's children */
9416 op_sibling_splice((OP*)range, NULL, -1, NULL);
9417
9418 listop = cLISTOPx(newLISTOP(OP_LIST, 0, left, right));
9419 listop->op_first->op_next = range->op_next;
9420 left->op_next = range->op_other;
9421 right->op_next = (OP*)listop;
9422 listop->op_next = listop->op_first;
9423
9424 op_free(expr);
9425 expr = (OP*)(listop);
9426 op_null(expr);
9427 iterflags |= OPf_STACKED;
9428 }
9429 else {
9430 expr = op_lvalue(op_force_list(expr), OP_GREPSTART);
9431 }
9432
9433 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
9434 op_append_elem(OP_LIST, list(expr),
9435 scalar(sv)));
9436 assert(!loop->op_next);
9437 /* for my $x () sets OPpLVAL_INTRO;
9438 * for our $x () sets OPpOUR_INTRO */
9439 loop->op_private = (U8)iterpflags;
9440
9441 /* upgrade loop from a LISTOP to a LOOPOP;
9442 * keep it in-place if there's space */
9443 if (loop->op_slabbed
9444 && OpSLOT(loop)->opslot_size
9445 < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
9446 {
9447 /* no space; allocate new op */
9448 LOOP *tmp;
9449 NewOp(1234,tmp,1,LOOP);
9450 Copy(loop,tmp,1,LISTOP);
9451 assert(loop->op_last->op_sibparent == (OP*)loop);
9452 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
9453 S_op_destroy(aTHX_ (OP*)loop);
9454 loop = tmp;
9455 }
9456 else if (!loop->op_slabbed)
9457 {
9458 /* loop was malloc()ed */
9459 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
9460 OpLASTSIB_set(loop->op_last, (OP*)loop);
9461 }
9462 loop->op_targ = padoff;
9463 if (parens)
9464 /* hint to deparser that this: for my (...) ... */
9465 loop->op_flags |= OPf_PARENS;
9466 iter = newOP(OP_ITER, 0);
9467 iter->op_targ = how_many_more;
9468 return newWHILEOP(flags, 1, loop, iter, block, cont, 0);
9469 }
9470
9471 /*
9472 =for apidoc newLOOPEX
9473
9474 Constructs, checks, and returns a loop-exiting op (such as C<goto>
9475 or C<last>). C<type> is the opcode. C<label> supplies the parameter
9476 determining the target of the op; it is consumed by this function and
9477 becomes part of the constructed op tree.
9478
9479 =cut
9480 */
9481
9482 OP*
Perl_newLOOPEX(pTHX_ I32 type,OP * label)9483 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
9484 {
9485 OP *o = NULL;
9486
9487 PERL_ARGS_ASSERT_NEWLOOPEX;
9488
9489 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9490 || type == OP_CUSTOM);
9491
9492 if (type != OP_GOTO) {
9493 /* "last()" means "last" */
9494 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9495 o = newOP(type, OPf_SPECIAL);
9496 }
9497 }
9498 else {
9499 /* Check whether it's going to be a goto &function */
9500 if (label->op_type == OP_ENTERSUB
9501 && !(label->op_flags & OPf_STACKED))
9502 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9503 }
9504
9505 /* Check for a constant argument */
9506 if (label->op_type == OP_CONST) {
9507 SV * const sv = cSVOPx(label)->op_sv;
9508 STRLEN l;
9509 const char *s = SvPV_const(sv,l);
9510 if (l == strlen(s)) {
9511 o = newPVOP(type,
9512 SvUTF8(cSVOPx(label)->op_sv),
9513 savesharedpv(
9514 SvPV_nolen_const(cSVOPx(label)->op_sv)));
9515 }
9516 }
9517
9518 /* If we have already created an op, we do not need the label. */
9519 if (o)
9520 op_free(label);
9521 else o = newUNOP(type, OPf_STACKED, label);
9522
9523 PL_hints |= HINT_BLOCK_SCOPE;
9524 return o;
9525 }
9526
9527 /* if the condition is a literal array or hash
9528 (or @{ ... } etc), make a reference to it.
9529 */
9530 STATIC OP *
S_ref_array_or_hash(pTHX_ OP * cond)9531 S_ref_array_or_hash(pTHX_ OP *cond)
9532 {
9533 if (cond
9534 && (cond->op_type == OP_RV2AV
9535 || cond->op_type == OP_PADAV
9536 || cond->op_type == OP_RV2HV
9537 || cond->op_type == OP_PADHV))
9538
9539 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9540
9541 else if(cond
9542 && (cond->op_type == OP_ASLICE
9543 || cond->op_type == OP_KVASLICE
9544 || cond->op_type == OP_HSLICE
9545 || cond->op_type == OP_KVHSLICE)) {
9546
9547 /* anonlist now needs a list from this op, was previously used in
9548 * scalar context */
9549 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9550 cond->op_flags |= OPf_WANT_LIST;
9551
9552 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9553 }
9554
9555 else
9556 return cond;
9557 }
9558
9559 /* These construct the optree fragments representing given()
9560 and when() blocks.
9561
9562 entergiven and enterwhen are LOGOPs; the op_other pointer
9563 points up to the associated leave op. We need this so we
9564 can put it in the context and make break/continue work.
9565 (Also, of course, pp_enterwhen will jump straight to
9566 op_other if the match fails.)
9567 */
9568
9569 STATIC OP *
S_newGIVWHENOP(pTHX_ OP * cond,OP * block,I32 enter_opcode,I32 leave_opcode,PADOFFSET entertarg)9570 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9571 I32 enter_opcode, I32 leave_opcode,
9572 PADOFFSET entertarg)
9573 {
9574 LOGOP *enterop;
9575 OP *o;
9576
9577 PERL_ARGS_ASSERT_NEWGIVWHENOP;
9578 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9579
9580 enterop = alloc_LOGOP(enter_opcode, block, NULL);
9581 enterop->op_targ = 0;
9582 enterop->op_private = 0;
9583
9584 o = newUNOP(leave_opcode, 0, (OP *) enterop);
9585
9586 if (cond) {
9587 /* prepend cond if we have one */
9588 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9589
9590 o->op_next = LINKLIST(cond);
9591 cond->op_next = (OP *) enterop;
9592 }
9593 else {
9594 /* This is a default {} block */
9595 enterop->op_flags |= OPf_SPECIAL;
9596 o ->op_flags |= OPf_SPECIAL;
9597
9598 o->op_next = (OP *) enterop;
9599 }
9600
9601 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9602 entergiven and enterwhen both
9603 use ck_null() */
9604
9605 enterop->op_next = LINKLIST(block);
9606 block->op_next = enterop->op_other = o;
9607
9608 return o;
9609 }
9610
9611
9612 /* For the purposes of 'when(implied_smartmatch)'
9613 * versus 'when(boolean_expression)',
9614 * does this look like a boolean operation? For these purposes
9615 a boolean operation is:
9616 - a subroutine call [*]
9617 - a logical connective
9618 - a comparison operator
9619 - a filetest operator, with the exception of -s -M -A -C
9620 - defined(), exists() or eof()
9621 - /$re/ or $foo =~ /$re/
9622
9623 [*] possibly surprising
9624 */
9625 STATIC bool
S_looks_like_bool(pTHX_ const OP * o)9626 S_looks_like_bool(pTHX_ const OP *o)
9627 {
9628 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9629
9630 switch(o->op_type) {
9631 case OP_OR:
9632 case OP_DOR:
9633 return looks_like_bool(cLOGOPo->op_first);
9634
9635 case OP_AND:
9636 {
9637 OP* sibl = OpSIBLING(cLOGOPo->op_first);
9638 ASSUME(sibl);
9639 return (
9640 looks_like_bool(cLOGOPo->op_first)
9641 && looks_like_bool(sibl));
9642 }
9643
9644 case OP_NULL:
9645 case OP_SCALAR:
9646 return (
9647 o->op_flags & OPf_KIDS
9648 && looks_like_bool(cUNOPo->op_first));
9649
9650 case OP_ENTERSUB:
9651
9652 case OP_NOT: case OP_XOR:
9653
9654 case OP_EQ: case OP_NE: case OP_LT:
9655 case OP_GT: case OP_LE: case OP_GE:
9656
9657 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
9658 case OP_I_GT: case OP_I_LE: case OP_I_GE:
9659
9660 case OP_SEQ: case OP_SNE: case OP_SLT:
9661 case OP_SGT: case OP_SLE: case OP_SGE:
9662
9663 case OP_SMARTMATCH:
9664
9665 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
9666 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
9667 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
9668 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
9669 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
9670 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
9671 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
9672 case OP_FTTEXT: case OP_FTBINARY:
9673
9674 case OP_DEFINED: case OP_EXISTS:
9675 case OP_MATCH: case OP_EOF:
9676
9677 case OP_FLOP:
9678
9679 return TRUE;
9680
9681 case OP_INDEX:
9682 case OP_RINDEX:
9683 /* optimised-away (index() != -1) or similar comparison */
9684 if (o->op_private & OPpTRUEBOOL)
9685 return TRUE;
9686 return FALSE;
9687
9688 case OP_CONST:
9689 /* Detect comparisons that have been optimized away */
9690 if (cSVOPo->op_sv == &PL_sv_yes
9691 || cSVOPo->op_sv == &PL_sv_no)
9692
9693 return TRUE;
9694 else
9695 return FALSE;
9696 /* FALLTHROUGH */
9697 default:
9698 return FALSE;
9699 }
9700 }
9701
9702
9703 /*
9704 =for apidoc newGIVENOP
9705
9706 Constructs, checks, and returns an op tree expressing a C<given> block.
9707 C<cond> supplies the expression to whose value C<$_> will be locally
9708 aliased, and C<block> supplies the body of the C<given> construct; they
9709 are consumed by this function and become part of the constructed op tree.
9710 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9711
9712 =cut
9713 */
9714
9715 OP *
Perl_newGIVENOP(pTHX_ OP * cond,OP * block,PADOFFSET defsv_off)9716 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9717 {
9718 PERL_ARGS_ASSERT_NEWGIVENOP;
9719 PERL_UNUSED_ARG(defsv_off);
9720
9721 assert(!defsv_off);
9722 return newGIVWHENOP(
9723 ref_array_or_hash(cond),
9724 block,
9725 OP_ENTERGIVEN, OP_LEAVEGIVEN,
9726 0);
9727 }
9728
9729 /*
9730 =for apidoc newWHENOP
9731
9732 Constructs, checks, and returns an op tree expressing a C<when> block.
9733 C<cond> supplies the test expression, and C<block> supplies the block
9734 that will be executed if the test evaluates to true; they are consumed
9735 by this function and become part of the constructed op tree. C<cond>
9736 will be interpreted DWIMically, often as a comparison against C<$_>,
9737 and may be null to generate a C<default> block.
9738
9739 =cut
9740 */
9741
9742 OP *
Perl_newWHENOP(pTHX_ OP * cond,OP * block)9743 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9744 {
9745 const bool cond_llb = (!cond || looks_like_bool(cond));
9746 OP *cond_op;
9747
9748 PERL_ARGS_ASSERT_NEWWHENOP;
9749
9750 if (cond_llb)
9751 cond_op = cond;
9752 else {
9753 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9754 newDEFSVOP(),
9755 scalar(ref_array_or_hash(cond)));
9756 }
9757
9758 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9759 }
9760
9761 /*
9762 =for apidoc newDEFEROP
9763
9764 Constructs and returns a deferred-block statement that implements the
9765 C<defer> semantics. The C<block> optree is consumed by this function and
9766 becomes part of the returned optree.
9767
9768 The C<flags> argument carries additional flags to set on the returned op,
9769 including the C<op_private> field.
9770
9771 =cut
9772 */
9773
9774 OP *
Perl_newDEFEROP(pTHX_ I32 flags,OP * block)9775 Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
9776 {
9777 OP *o, *start, *blockfirst;
9778
9779 PERL_ARGS_ASSERT_NEWDEFEROP;
9780
9781 forbid_outofblock_ops(block,
9782 (flags & (OPpDEFER_FINALLY << 8)) ? "a \"finally\" block" : "a \"defer\" block");
9783
9784 start = LINKLIST(block);
9785
9786 /* Hide the block inside an OP_NULL with no execution */
9787 block = newUNOP(OP_NULL, 0, block);
9788 block->op_next = block;
9789
9790 o = (OP *)alloc_LOGOP(OP_PUSHDEFER, block, start);
9791 o->op_flags |= OPf_WANT_VOID | (U8)(flags);
9792 o->op_private = (U8)(flags >> 8);
9793
9794 /* Terminate the block */
9795 blockfirst = cUNOPx(block)->op_first;
9796 assert(blockfirst->op_type == OP_SCOPE || blockfirst->op_type == OP_LEAVE);
9797 blockfirst->op_next = NULL;
9798
9799 return o;
9800 }
9801
9802 /*
9803 =for apidoc op_wrap_finally
9804
9805 Wraps the given C<block> optree fragment in its own scoped block, arranging
9806 for the C<finally> optree fragment to be invoked when leaving that block for
9807 any reason. Both optree fragments are consumed and the combined result is
9808 returned.
9809
9810 =cut
9811 */
9812
9813 OP *
Perl_op_wrap_finally(pTHX_ OP * block,OP * finally)9814 Perl_op_wrap_finally(pTHX_ OP *block, OP *finally)
9815 {
9816 PERL_ARGS_ASSERT_OP_WRAP_FINALLY;
9817
9818 /* TODO: If block is already an ENTER/LEAVE-wrapped line sequence we can
9819 * just splice the DEFEROP in at the top, for efficiency.
9820 */
9821
9822 OP *o = newLISTOP(OP_LINESEQ, 0, newDEFEROP((OPpDEFER_FINALLY << 8), finally), block);
9823 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
9824 OpTYPE_set(o, OP_LEAVE);
9825
9826 return o;
9827 }
9828
9829 /* must not conflict with SVf_UTF8 */
9830 #define CV_CKPROTO_CURSTASH 0x1
9831
9832 void
Perl_cv_ckproto_len_flags(pTHX_ const CV * cv,const GV * gv,const char * p,const STRLEN len,const U32 flags)9833 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9834 const STRLEN len, const U32 flags)
9835 {
9836 SV *name = NULL, *msg;
9837 const char * cvp = SvROK(cv)
9838 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9839 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9840 : ""
9841 : CvPROTO(cv);
9842 STRLEN clen = CvPROTOLEN(cv), plen = len;
9843
9844 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9845
9846 if (p == NULL && cvp == NULL)
9847 return;
9848
9849 if (!ckWARN_d(WARN_PROTOTYPE))
9850 return;
9851
9852 if (p && cvp) {
9853 p = S_strip_spaces(aTHX_ p, &plen);
9854 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9855 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9856 if (plen == clen && memEQ(cvp, p, plen))
9857 return;
9858 } else {
9859 if (flags & SVf_UTF8) {
9860 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9861 return;
9862 }
9863 else {
9864 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9865 return;
9866 }
9867 }
9868 }
9869
9870 msg = sv_newmortal();
9871
9872 if (gv)
9873 {
9874 if (isGV(gv))
9875 gv_efullname3(name = sv_newmortal(), gv, NULL);
9876 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9877 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9878 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9879 name = newSVhek_mortal(HvNAME_HEK(PL_curstash));
9880 sv_catpvs(name, "::");
9881 if (SvROK(gv)) {
9882 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9883 assert (CvNAMED(SvRV_const(gv)));
9884 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9885 }
9886 else sv_catsv(name, (SV *)gv);
9887 }
9888 else name = (SV *)gv;
9889 }
9890 sv_setpvs(msg, "Prototype mismatch:");
9891 if (name)
9892 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9893 if (cvp)
9894 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9895 UTF8fARG(SvUTF8(cv),clen,cvp)
9896 );
9897 else
9898 sv_catpvs(msg, ": none");
9899 sv_catpvs(msg, " vs ");
9900 if (p)
9901 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9902 else
9903 sv_catpvs(msg, "none");
9904 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9905 }
9906
9907 static void const_sv_xsub(pTHX_ CV* cv);
9908 static void const_av_xsub(pTHX_ CV* cv);
9909
9910 /*
9911
9912 =for apidoc_section $optree_manipulation
9913
9914 =for apidoc cv_const_sv
9915
9916 If C<cv> is a constant sub eligible for inlining, returns the constant
9917 value returned by the sub. Otherwise, returns C<NULL>.
9918
9919 Constant subs can be created with C<newCONSTSUB> or as described in
9920 L<perlsub/"Constant Functions">.
9921
9922 =cut
9923 */
9924 SV *
Perl_cv_const_sv(const CV * const cv)9925 Perl_cv_const_sv(const CV *const cv)
9926 {
9927 SV *sv;
9928 if (!cv)
9929 return NULL;
9930 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9931 return NULL;
9932 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9933 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9934 return sv;
9935 }
9936
9937 SV *
Perl_cv_const_sv_or_av(const CV * const cv)9938 Perl_cv_const_sv_or_av(const CV * const cv)
9939 {
9940 if (!cv)
9941 return NULL;
9942 if (SvROK(cv)) return SvRV((SV *)cv);
9943 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9944 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9945 }
9946
9947 /* op_const_sv: examine an optree to determine whether it's in-lineable.
9948 * Can be called in 2 ways:
9949 *
9950 * !allow_lex
9951 * look for a single OP_CONST with attached value: return the value
9952 *
9953 * allow_lex && !CvCONST(cv);
9954 *
9955 * examine the clone prototype, and if contains only a single
9956 * OP_CONST, return the value; or if it contains a single PADSV ref-
9957 * erencing an outer lexical, turn on CvCONST to indicate the CV is
9958 * a candidate for "constizing" at clone time, and return NULL.
9959 */
9960
9961 static SV *
S_op_const_sv(pTHX_ const OP * o,CV * cv,bool allow_lex)9962 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9963 {
9964 SV *sv = NULL;
9965 bool padsv = FALSE;
9966
9967 assert(o);
9968 assert(cv);
9969
9970 for (; o; o = o->op_next) {
9971 const OPCODE type = o->op_type;
9972
9973 if (type == OP_NEXTSTATE || type == OP_LINESEQ
9974 || type == OP_NULL
9975 || type == OP_PUSHMARK)
9976 continue;
9977 if (type == OP_DBSTATE)
9978 continue;
9979 if (type == OP_LEAVESUB)
9980 break;
9981 if (sv)
9982 return NULL;
9983 if (type == OP_CONST && cSVOPo->op_sv)
9984 sv = cSVOPo->op_sv;
9985 else if (type == OP_UNDEF && !o->op_private) {
9986 sv = newSV_type(SVt_NULL);
9987 SAVEFREESV(sv);
9988 }
9989 else if (allow_lex && type == OP_PADSV) {
9990 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEf_OUTER)
9991 {
9992 sv = &PL_sv_undef; /* an arbitrary non-null value */
9993 padsv = TRUE;
9994 }
9995 else
9996 return NULL;
9997 }
9998 else {
9999 return NULL;
10000 }
10001 }
10002 if (padsv) {
10003 CvCONST_on(cv);
10004 return NULL;
10005 }
10006 return sv;
10007 }
10008
10009 static void
S_already_defined(pTHX_ CV * const cv,OP * const block,OP * const o,PADNAME * const name,SV ** const const_svp)10010 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10011 PADNAME * const name, SV ** const const_svp)
10012 {
10013 assert (cv);
10014 assert (o || name);
10015 assert (const_svp);
10016 if (!block) {
10017 if (CvFLAGS(PL_compcv)) {
10018 /* might have had built-in attrs applied */
10019 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10020 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10021 && ckWARN(WARN_MISC))
10022 {
10023 /* protect against fatal warnings leaking compcv */
10024 SAVEFREESV(PL_compcv);
10025 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10026 SvREFCNT_inc_simple_void_NN(PL_compcv);
10027 }
10028 CvFLAGS(cv) |=
10029 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10030 & ~(CVf_LVALUE * pureperl));
10031 }
10032 return;
10033 }
10034
10035 /* redundant check for speed: */
10036 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10037 const line_t oldline = CopLINE(PL_curcop);
10038 SV *namesv = o
10039 ? cSVOPo->op_sv
10040 : newSVpvn_flags( PadnamePV(name)+1,PadnameLEN(name)-1,
10041 (PadnameUTF8(name)) ? SVf_UTF8|SVs_TEMP : SVs_TEMP
10042 );
10043 if (PL_parser && PL_parser->copline != NOLINE)
10044 /* This ensures that warnings are reported at the first
10045 line of a redefinition, not the last. */
10046 CopLINE_set(PL_curcop, PL_parser->copline);
10047 /* protect against fatal warnings leaking compcv */
10048 SAVEFREESV(PL_compcv);
10049 report_redefined_cv(namesv, cv, const_svp);
10050 SvREFCNT_inc_simple_void_NN(PL_compcv);
10051 CopLINE_set(PL_curcop, oldline);
10052 }
10053 SAVEFREESV(cv);
10054 return;
10055 }
10056
10057 CV *
Perl_newMYSUB(pTHX_ I32 floor,OP * o,OP * proto,OP * attrs,OP * block)10058 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10059 {
10060 CV **spot;
10061 SV **svspot;
10062 const char *ps;
10063 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10064 U32 ps_utf8 = 0;
10065 CV *cv = NULL;
10066 CV *compcv = PL_compcv;
10067 SV *const_sv;
10068 PADNAME *name;
10069 PADOFFSET pax = o->op_targ;
10070 CV *outcv = CvOUTSIDE(PL_compcv);
10071 CV *clonee = NULL;
10072 HEK *hek = NULL;
10073 bool reusable = FALSE;
10074 OP *start = NULL;
10075 #ifdef PERL_DEBUG_READONLY_OPS
10076 OPSLAB *slab = NULL;
10077 #endif
10078
10079 PERL_ARGS_ASSERT_NEWMYSUB;
10080
10081 PL_hints |= HINT_BLOCK_SCOPE;
10082
10083 /* Find the pad slot for storing the new sub.
10084 We cannot use PL_comppad, as it is the pad owned by the new sub. We
10085 need to look in CvOUTSIDE and find the pad belonging to the enclos-
10086 ing sub. And then we need to dig deeper if this is a lexical from
10087 outside, as in:
10088 my sub foo; sub { sub foo { } }
10089 */
10090 redo:
10091 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10092 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10093 pax = PARENT_PAD_INDEX(name);
10094 outcv = CvOUTSIDE(outcv);
10095 assert(outcv);
10096 goto redo;
10097 }
10098 svspot =
10099 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10100 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10101 spot = (CV **)svspot;
10102
10103 if (!(PL_parser && PL_parser->error_count))
10104 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10105
10106 if (proto) {
10107 assert(proto->op_type == OP_CONST);
10108 ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
10109 ps_utf8 = SvUTF8(cSVOPx(proto)->op_sv);
10110 }
10111 else
10112 ps = NULL;
10113
10114 if (proto)
10115 SAVEFREEOP(proto);
10116 if (attrs)
10117 SAVEFREEOP(attrs);
10118
10119 if (PL_parser && PL_parser->error_count) {
10120 op_free(block);
10121 SvREFCNT_dec(PL_compcv);
10122 PL_compcv = 0;
10123 goto done;
10124 }
10125
10126 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10127 cv = *spot;
10128 svspot = (SV **)(spot = &clonee);
10129 }
10130 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10131 cv = *spot;
10132 else {
10133 assert (SvTYPE(*spot) == SVt_PVCV);
10134 if (CvNAMED(*spot))
10135 hek = CvNAME_HEK(*spot);
10136 else {
10137 U32 hash;
10138 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10139 CvNAME_HEK_set(*spot, hek =
10140 share_hek(
10141 PadnamePV(name)+1,
10142 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10143 hash
10144 )
10145 );
10146 CvLEXICAL_on(*spot);
10147 }
10148 cv = PadnamePROTOCV(name);
10149 svspot = (SV **)(spot = &PadnamePROTOCV(name));
10150 }
10151
10152 if (block) {
10153 /* This makes sub {}; work as expected. */
10154 if (block->op_type == OP_STUB) {
10155 const line_t l = PL_parser->copline;
10156 op_free(block);
10157 block = newSTATEOP(0, NULL, 0);
10158 PL_parser->copline = l;
10159 }
10160 block = CvLVALUE(compcv)
10161 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10162 ? newUNOP(OP_LEAVESUBLV, 0,
10163 op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
10164 : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
10165 start = LINKLIST(block);
10166 block->op_next = 0;
10167 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10168 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10169 else
10170 const_sv = NULL;
10171 }
10172 else
10173 const_sv = NULL;
10174
10175 if (cv) {
10176 const bool exists = CvROOT(cv) || CvXSUB(cv);
10177
10178 /* if the subroutine doesn't exist and wasn't pre-declared
10179 * with a prototype, assume it will be AUTOLOADed,
10180 * skipping the prototype check
10181 */
10182 if (exists || SvPOK(cv))
10183 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10184 ps_utf8);
10185 /* already defined? */
10186 if (exists) {
10187 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10188 if (block)
10189 cv = NULL;
10190 else {
10191 if (attrs)
10192 goto attrs;
10193 /* just a "sub foo;" when &foo is already defined */
10194 SAVEFREESV(compcv);
10195 goto done;
10196 }
10197 }
10198 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10199 cv = NULL;
10200 reusable = TRUE;
10201 }
10202 }
10203
10204 if (const_sv) {
10205 SvREFCNT_inc_simple_void_NN(const_sv);
10206 SvFLAGS(const_sv) |= SVs_PADTMP;
10207 if (cv) {
10208 assert(!CvROOT(cv) && !CvCONST(cv));
10209 cv_forget_slab(cv);
10210 }
10211 else {
10212 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10213 CvFILE_set_from_cop(cv, PL_curcop);
10214 CvSTASH_set(cv, PL_curstash);
10215 *spot = cv;
10216 }
10217 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10218 CvXSUBANY(cv).any_ptr = const_sv;
10219 CvXSUB(cv) = const_sv_xsub;
10220 CvCONST_on(cv);
10221 CvISXSUB_on(cv);
10222 PoisonPADLIST(cv);
10223 CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(compcv);
10224 op_free(block);
10225 SvREFCNT_dec(compcv);
10226 PL_compcv = NULL;
10227 goto setname;
10228 }
10229
10230 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10231 determine whether this sub definition is in the same scope as its
10232 declaration. If this sub definition is inside an inner named pack-
10233 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10234 the package sub. So check PadnameOUTER(name) too.
10235 */
10236 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10237 assert(!CvWEAKOUTSIDE(compcv));
10238 SvREFCNT_dec(CvOUTSIDE(compcv));
10239 CvWEAKOUTSIDE_on(compcv);
10240 }
10241 /* XXX else do we have a circular reference? */
10242
10243 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
10244 /* transfer PL_compcv to cv */
10245 if (block) {
10246 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10247 cv_flags_t preserved_flags =
10248 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10249 PADLIST *const temp_padl = CvPADLIST(cv);
10250 CV *const temp_cv = CvOUTSIDE(cv);
10251 const cv_flags_t other_flags =
10252 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10253 OP * const cvstart = CvSTART(cv);
10254
10255 SvPOK_off(cv);
10256 CvFLAGS(cv) =
10257 CvFLAGS(compcv) | preserved_flags;
10258 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10259 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10260 CvPADLIST_set(cv, CvPADLIST(compcv));
10261 CvOUTSIDE(compcv) = temp_cv;
10262 CvPADLIST_set(compcv, temp_padl);
10263 CvSTART(cv) = CvSTART(compcv);
10264 CvSTART(compcv) = cvstart;
10265 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10266 CvFLAGS(compcv) |= other_flags;
10267
10268 if (free_file) {
10269 Safefree(CvFILE(cv));
10270 CvFILE(cv) = NULL;
10271 }
10272
10273 /* inner references to compcv must be fixed up ... */
10274 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10275 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10276 ++PL_sub_generation;
10277 }
10278 else {
10279 /* Might have had built-in attributes applied -- propagate them. */
10280 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10281 }
10282 /* ... before we throw it away */
10283 SvREFCNT_dec(compcv);
10284 PL_compcv = compcv = cv;
10285 }
10286 else {
10287 cv = compcv;
10288 *spot = cv;
10289 }
10290
10291 setname:
10292 CvLEXICAL_on(cv);
10293 if (!CvNAME_HEK(cv)) {
10294 if (hek) (void)share_hek_hek(hek);
10295 else {
10296 U32 hash;
10297 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10298 hek = share_hek(PadnamePV(name)+1,
10299 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10300 hash);
10301 }
10302 CvNAME_HEK_set(cv, hek);
10303 }
10304
10305 if (const_sv)
10306 goto clone;
10307
10308 if (CvFILE(cv) && CvDYNFILE(cv))
10309 Safefree(CvFILE(cv));
10310 CvFILE_set_from_cop(cv, PL_curcop);
10311 CvSTASH_set(cv, PL_curstash);
10312
10313 if (ps) {
10314 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10315 if (ps_utf8)
10316 SvUTF8_on(MUTABLE_SV(cv));
10317 }
10318
10319 if (block) {
10320 /* If we assign an optree to a PVCV, then we've defined a
10321 * subroutine that the debugger could be able to set a breakpoint
10322 * in, so signal to pp_entereval that it should not throw away any
10323 * saved lines at scope exit. */
10324
10325 PL_breakable_sub_gen++;
10326 CvROOT(cv) = block;
10327 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10328 itself has a refcount. */
10329 CvSLABBED_off(cv);
10330 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10331 #ifdef PERL_DEBUG_READONLY_OPS
10332 slab = (OPSLAB *)CvSTART(cv);
10333 #endif
10334 S_process_optree(aTHX_ cv, block, start);
10335 }
10336
10337 attrs:
10338 if (attrs) {
10339 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10340 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
10341 }
10342
10343 if (block) {
10344 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10345 SV * const tmpstr = sv_newmortal();
10346 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10347 GV_ADDMULTI, SVt_PVHV);
10348 HV *hv;
10349 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" LINE_Tf "-%" LINE_Tf,
10350 CopFILE(PL_curcop),
10351 (line_t)PL_subline,
10352 CopLINE(PL_curcop));
10353 if (HvNAME_HEK(PL_curstash)) {
10354 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
10355 sv_catpvs(tmpstr, "::");
10356 }
10357 else
10358 sv_setpvs(tmpstr, "__ANON__::");
10359
10360 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
10361 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
10362 (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
10363 hv = GvHVn(db_postponed);
10364 if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
10365 CV * const pcv = GvCV(db_postponed);
10366 if (pcv) {
10367 dSP;
10368 PUSHMARK(SP);
10369 XPUSHs(tmpstr);
10370 PUTBACK;
10371 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10372 }
10373 }
10374 }
10375 }
10376
10377 clone:
10378 if (clonee) {
10379 assert(CvDEPTH(outcv));
10380 spot = (CV **)
10381 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
10382 if (reusable)
10383 cv_clone_into(clonee, *spot);
10384 else *spot = cv_clone(clonee);
10385 SvREFCNT_dec_NN(clonee);
10386 cv = *spot;
10387 }
10388
10389 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
10390 PADOFFSET depth = CvDEPTH(outcv);
10391 while (--depth) {
10392 SV *oldcv;
10393 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
10394 oldcv = *svspot;
10395 *svspot = SvREFCNT_inc_simple_NN(cv);
10396 SvREFCNT_dec(oldcv);
10397 }
10398 }
10399
10400 done:
10401 if (PL_parser)
10402 PL_parser->copline = NOLINE;
10403 LEAVE_SCOPE(floor);
10404 #ifdef PERL_DEBUG_READONLY_OPS
10405 if (slab)
10406 Slab_to_ro(slab);
10407 #endif
10408 op_free(o);
10409 return cv;
10410 }
10411
10412 /*
10413 =for apidoc newATTRSUB_x
10414
10415 Construct a Perl subroutine, also performing some surrounding jobs.
10416
10417 This function is expected to be called in a Perl compilation context,
10418 and some aspects of the subroutine are taken from global variables
10419 associated with compilation. In particular, C<PL_compcv> represents
10420 the subroutine that is currently being compiled. It must be non-null
10421 when this function is called, and some aspects of the subroutine being
10422 constructed are taken from it. The constructed subroutine may actually
10423 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
10424
10425 If C<block> is null then the subroutine will have no body, and for the
10426 time being it will be an error to call it. This represents a forward
10427 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
10428 non-null then it provides the Perl code of the subroutine body, which
10429 will be executed when the subroutine is called. This body includes
10430 any argument unwrapping code resulting from a subroutine signature or
10431 similar. The pad use of the code must correspond to the pad attached
10432 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
10433 C<leavesublv> op; this function will add such an op. C<block> is consumed
10434 by this function and will become part of the constructed subroutine.
10435
10436 C<proto> specifies the subroutine's prototype, unless one is supplied
10437 as an attribute (see below). If C<proto> is null, then the subroutine
10438 will not have a prototype. If C<proto> is non-null, it must point to a
10439 C<const> op whose value is a string, and the subroutine will have that
10440 string as its prototype. If a prototype is supplied as an attribute, the
10441 attribute takes precedence over C<proto>, but in that case C<proto> should
10442 preferably be null. In any case, C<proto> is consumed by this function.
10443
10444 C<attrs> supplies attributes to be applied the subroutine. A handful of
10445 attributes take effect by built-in means, being applied to C<PL_compcv>
10446 immediately when seen. Other attributes are collected up and attached
10447 to the subroutine by this route. C<attrs> may be null to supply no
10448 attributes, or point to a C<const> op for a single attribute, or point
10449 to a C<list> op whose children apart from the C<pushmark> are C<const>
10450 ops for one or more attributes. Each C<const> op must be a string,
10451 giving the attribute name optionally followed by parenthesised arguments,
10452 in the manner in which attributes appear in Perl source. The attributes
10453 will be applied to the sub by this function. C<attrs> is consumed by
10454 this function.
10455
10456 If C<o_is_gv> is false and C<o> is null, then the subroutine will
10457 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
10458 must point to a C<const> OP, which will be consumed by this function,
10459 and its string value supplies a name for the subroutine. The name may
10460 be qualified or unqualified, and if it is unqualified then a default
10461 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
10462 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
10463 by which the subroutine will be named.
10464
10465 If there is already a subroutine of the specified name, then the new
10466 sub will either replace the existing one in the glob or be merged with
10467 the existing one. A warning may be generated about redefinition.
10468
10469 If the subroutine has one of a few special names, such as C<BEGIN> or
10470 C<END>, then it will be claimed by the appropriate queue for automatic
10471 running of phase-related subroutines. In this case the relevant glob will
10472 be left not containing any subroutine, even if it did contain one before.
10473 In the case of C<BEGIN>, the subroutine will be executed and the reference
10474 to it disposed of before this function returns.
10475
10476 The function returns a pointer to the constructed subroutine. If the sub
10477 is anonymous then ownership of one counted reference to the subroutine
10478 is transferred to the caller. If the sub is named then the caller does
10479 not get ownership of a reference. In most such cases, where the sub
10480 has a non-phase name, the sub will be alive at the point it is returned
10481 by virtue of being contained in the glob that names it. A phase-named
10482 subroutine will usually be alive by virtue of the reference owned by the
10483 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10484 been executed, will quite likely have been destroyed already by the
10485 time this function returns, making it erroneous for the caller to make
10486 any use of the returned pointer. It is the caller's responsibility to
10487 ensure that it knows which of these situations applies.
10488
10489 =for apidoc newATTRSUB
10490 Construct a Perl subroutine, also performing some surrounding jobs.
10491
10492 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter set to
10493 FALSE. This means that if C<o> is null, the new sub will be anonymous; otherwise
10494 the name will be derived from C<o> in the way described (as with all other
10495 details) in L<perlintern/C<newATTRSUB_x>>.
10496
10497 =for apidoc newSUB
10498 Like C<L</newATTRSUB>>, but without attributes.
10499
10500 =cut
10501 */
10502
10503 /* _x = extended */
10504 CV *
Perl_newATTRSUB_x(pTHX_ I32 floor,OP * o,OP * proto,OP * attrs,OP * block,bool o_is_gv)10505 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
10506 OP *block, bool o_is_gv)
10507 {
10508 GV *gv;
10509 const char *ps;
10510 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10511 U32 ps_utf8 = 0;
10512 CV *cv = NULL; /* the previous CV with this name, if any */
10513 SV *const_sv;
10514 const bool ec = PL_parser && PL_parser->error_count;
10515 /* If the subroutine has no body, no attributes, and no builtin attributes
10516 then it's just a sub declaration, and we may be able to get away with
10517 storing with a placeholder scalar in the symbol table, rather than a
10518 full CV. If anything is present then it will take a full CV to
10519 store it. */
10520 const I32 gv_fetch_flags
10521 = ec ? GV_NOADD_NOINIT :
10522 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
10523 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
10524 STRLEN namlen = 0;
10525 const char * const name =
10526 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
10527 bool has_name;
10528 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
10529 bool evanescent = FALSE;
10530 bool isBEGIN = FALSE;
10531 OP *start = NULL;
10532 #ifdef PERL_DEBUG_READONLY_OPS
10533 OPSLAB *slab = NULL;
10534 #endif
10535
10536 if (o_is_gv) {
10537 gv = (GV*)o;
10538 o = NULL;
10539 has_name = TRUE;
10540 } else if (name) {
10541 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
10542 hek and CvSTASH pointer together can imply the GV. If the name
10543 contains a package name, then GvSTASH(CvGV(cv)) may differ from
10544 CvSTASH, so forego the optimisation if we find any.
10545 Also, we may be called from load_module at run time, so
10546 PL_curstash (which sets CvSTASH) may not point to the stash the
10547 sub is stored in. */
10548 /* XXX This optimization is currently disabled for packages other
10549 than main, since there was too much CPAN breakage. */
10550 const I32 flags =
10551 ec ? GV_NOADD_NOINIT
10552 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
10553 || PL_curstash != PL_defstash
10554 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
10555 ? gv_fetch_flags
10556 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
10557 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
10558 has_name = TRUE;
10559 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
10560 SV * const sv = sv_newmortal();
10561 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" LINE_Tf "]",
10562 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10563 CopFILE(PL_curcop), CopLINE(PL_curcop));
10564 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
10565 has_name = TRUE;
10566 } else if (PL_curstash) {
10567 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10568 has_name = FALSE;
10569 } else {
10570 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10571 has_name = FALSE;
10572 }
10573
10574 if (!ec) {
10575 if (isGV(gv)) {
10576 move_proto_attr(&proto, &attrs, gv, 0);
10577 } else {
10578 assert(cSVOPo);
10579 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10580 }
10581 }
10582
10583 if (o)
10584 SAVEFREEOP(o);
10585 if (proto)
10586 SAVEFREEOP(proto);
10587 if (attrs)
10588 SAVEFREEOP(attrs);
10589
10590 /* we need this in two places later on, so set it up here */
10591 if (name && block) {
10592 const char *s = (char *) my_memrchr(name, ':', namlen);
10593 s = s ? s+1 : name;
10594 isBEGIN = strEQ(s,"BEGIN");
10595 }
10596
10597 if (isBEGIN) {
10598 /* Make sure that we do not have any prototypes or
10599 * attributes associated with this BEGIN block, as the block
10600 * is already done and dusted, and we will assert or worse
10601 * if we try to attach the prototype to the now essentially
10602 * nonexistent sub. */
10603 if (proto)
10604 /* diag_listed_as: %s on BEGIN block ignored */
10605 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Prototype on BEGIN block ignored");
10606 if (attrs)
10607 /* diag_listed_as: %s on BEGIN block ignored */
10608 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Attribute on BEGIN block ignored");
10609 proto = NULL;
10610 attrs = NULL;
10611 }
10612
10613 if (proto) {
10614 assert(proto->op_type == OP_CONST);
10615 ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
10616 ps_utf8 = SvUTF8(cSVOPx(proto)->op_sv);
10617 }
10618 else
10619 ps = NULL;
10620
10621 if (ec) {
10622 op_free(block);
10623
10624 if (name)
10625 SvREFCNT_dec(PL_compcv);
10626 else
10627 cv = PL_compcv;
10628
10629 PL_compcv = 0;
10630 if (isBEGIN) {
10631 if (PL_in_eval & EVAL_KEEPERR)
10632 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10633 else {
10634 SV * const errsv = ERRSV;
10635 /* force display of errors found but not reported */
10636 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10637 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10638 }
10639 }
10640 goto done;
10641 }
10642
10643 if (!block && SvTYPE(gv) != SVt_PVGV) {
10644 /* If we are not defining a new sub and the existing one is not a
10645 full GV + CV... */
10646 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10647 /* We are applying attributes to an existing sub, so we need it
10648 upgraded if it is a constant. */
10649 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10650 gv_init_pvn(gv, PL_curstash, name, namlen,
10651 SVf_UTF8 * name_is_utf8);
10652 }
10653 else { /* Maybe prototype now, and had at maximum
10654 a prototype or const/sub ref before. */
10655 if (SvTYPE(gv) > SVt_NULL) {
10656 cv_ckproto_len_flags((const CV *)gv,
10657 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10658 ps_len, ps_utf8);
10659 }
10660
10661 if (!SvROK(gv)) {
10662 if (ps) {
10663 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10664 if (ps_utf8)
10665 SvUTF8_on(MUTABLE_SV(gv));
10666 }
10667 else
10668 sv_setiv(MUTABLE_SV(gv), -1);
10669 }
10670
10671 SvREFCNT_dec(PL_compcv);
10672 cv = PL_compcv = NULL;
10673 goto done;
10674 }
10675 }
10676
10677 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10678 ? NULL
10679 : isGV(gv)
10680 ? GvCV(gv)
10681 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10682 ? (CV *)SvRV(gv)
10683 : NULL;
10684
10685 if (block) {
10686 assert(PL_parser);
10687 if (CvIsMETHOD(PL_compcv))
10688 block = class_wrap_method_body(block);
10689 /* This makes sub {}; work as expected. */
10690 if (block->op_type == OP_STUB) {
10691 const line_t l = PL_parser->copline;
10692 op_free(block);
10693 block = newSTATEOP(0, NULL, 0);
10694 PL_parser->copline = l;
10695 }
10696 block = CvLVALUE(PL_compcv)
10697 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10698 && (!isGV(gv) || !GvASSUMECV(gv)))
10699 ? newUNOP(OP_LEAVESUBLV, 0,
10700 op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
10701 : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
10702 start = LINKLIST(block);
10703 block->op_next = 0;
10704 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10705 const_sv =
10706 S_op_const_sv(aTHX_ start, PL_compcv,
10707 cBOOL(CvCLONE(PL_compcv)));
10708 else
10709 const_sv = NULL;
10710 }
10711 else
10712 const_sv = NULL;
10713
10714 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10715 cv_ckproto_len_flags((const CV *)gv,
10716 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10717 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10718 if (SvROK(gv)) {
10719 /* All the other code for sub redefinition warnings expects the
10720 clobbered sub to be a CV. Instead of making all those code
10721 paths more complex, just inline the RV version here. */
10722 const line_t oldline = CopLINE(PL_curcop);
10723 assert(IN_PERL_COMPILETIME);
10724 if (PL_parser && PL_parser->copline != NOLINE)
10725 /* This ensures that warnings are reported at the first
10726 line of a redefinition, not the last. */
10727 CopLINE_set(PL_curcop, PL_parser->copline);
10728 /* protect against fatal warnings leaking compcv */
10729 SAVEFREESV(PL_compcv);
10730
10731 if (ckWARN(WARN_REDEFINE)
10732 || ( ckWARN_d(WARN_REDEFINE)
10733 && ( !const_sv || SvRV(gv) == const_sv
10734 || SvTYPE(const_sv) == SVt_PVAV
10735 || SvTYPE(SvRV(gv)) == SVt_PVAV
10736 || sv_cmp(SvRV(gv), const_sv) ))) {
10737 assert(cSVOPo);
10738 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10739 "Constant subroutine %" SVf " redefined",
10740 SVfARG(cSVOPo->op_sv));
10741 }
10742
10743 SvREFCNT_inc_simple_void_NN(PL_compcv);
10744 CopLINE_set(PL_curcop, oldline);
10745 SvREFCNT_dec(SvRV(gv));
10746 }
10747 }
10748
10749 if (cv) {
10750 const bool exists = CvROOT(cv) || CvXSUB(cv);
10751
10752 /* if the subroutine doesn't exist and wasn't pre-declared
10753 * with a prototype, assume it will be AUTOLOADed,
10754 * skipping the prototype check
10755 */
10756 if (exists || SvPOK(cv))
10757 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10758 /* already defined (or promised)? */
10759 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10760 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10761 if (block)
10762 cv = NULL;
10763 else {
10764 if (attrs)
10765 goto attrs;
10766 /* just a "sub foo;" when &foo is already defined */
10767 SAVEFREESV(PL_compcv);
10768 goto done;
10769 }
10770 }
10771 }
10772
10773 if (const_sv) {
10774 SvREFCNT_inc_simple_void_NN(const_sv);
10775 SvFLAGS(const_sv) |= SVs_PADTMP;
10776 if (cv) {
10777 assert(!CvROOT(cv) && !CvCONST(cv));
10778 cv_forget_slab(cv);
10779 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10780 CvXSUBANY(cv).any_ptr = const_sv;
10781 CvXSUB(cv) = const_sv_xsub;
10782 CvCONST_on(cv);
10783 CvISXSUB_on(cv);
10784 PoisonPADLIST(cv);
10785 CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(PL_compcv);
10786 }
10787 else {
10788 if (isGV(gv) || CvNOWARN_AMBIGUOUS(PL_compcv)) {
10789 if (name && isGV(gv))
10790 GvCV_set(gv, NULL);
10791 cv = newCONSTSUB_flags(
10792 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10793 const_sv
10794 );
10795 assert(cv);
10796 assert(SvREFCNT((SV*)cv) != 0);
10797 CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(PL_compcv);
10798 }
10799 else {
10800 if (!SvROK(gv)) {
10801 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10802 prepare_SV_for_RV((SV *)gv);
10803 SvOK_off((SV *)gv);
10804 SvROK_on(gv);
10805 }
10806 SvRV_set(gv, const_sv);
10807 }
10808 }
10809 op_free(block);
10810 SvREFCNT_dec(PL_compcv);
10811 PL_compcv = NULL;
10812 goto done;
10813 }
10814
10815 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10816 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10817 cv = NULL;
10818
10819 if (cv) { /* must reuse cv if autoloaded */
10820 /* transfer PL_compcv to cv */
10821 if (block) {
10822 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10823 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10824 PADLIST *const temp_av = CvPADLIST(cv);
10825 CV *const temp_cv = CvOUTSIDE(cv);
10826 const cv_flags_t other_flags =
10827 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10828 OP * const cvstart = CvSTART(cv);
10829
10830 if (isGV(gv)) {
10831 CvGV_set(cv,gv);
10832 assert(!CvCVGV_RC(cv));
10833 assert(CvGV(cv) == gv);
10834 }
10835 else {
10836 U32 hash;
10837 PERL_HASH(hash, name, namlen);
10838 CvNAME_HEK_set(cv,
10839 share_hek(name,
10840 name_is_utf8
10841 ? -(SSize_t)namlen
10842 : (SSize_t)namlen,
10843 hash));
10844 }
10845
10846 SvPOK_off(cv);
10847 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10848 | CvNAMED(cv);
10849 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10850 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10851 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10852 CvOUTSIDE(PL_compcv) = temp_cv;
10853 CvPADLIST_set(PL_compcv, temp_av);
10854 CvSTART(cv) = CvSTART(PL_compcv);
10855 CvSTART(PL_compcv) = cvstart;
10856 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10857 CvFLAGS(PL_compcv) |= other_flags;
10858
10859 if (free_file) {
10860 Safefree(CvFILE(cv));
10861 }
10862 CvFILE_set_from_cop(cv, PL_curcop);
10863 CvSTASH_set(cv, PL_curstash);
10864
10865 /* inner references to PL_compcv must be fixed up ... */
10866 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10867 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10868 ++PL_sub_generation;
10869 }
10870 else {
10871 /* Might have had built-in attributes applied -- propagate them. */
10872 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10873 }
10874 /* ... before we throw it away */
10875 SvREFCNT_dec(PL_compcv);
10876 PL_compcv = cv;
10877 }
10878 else {
10879 cv = PL_compcv;
10880 if (name && isGV(gv)) {
10881 GvCV_set(gv, cv);
10882 GvCVGEN(gv) = 0;
10883 if (HvENAME_HEK(GvSTASH(gv)))
10884 /* sub Foo::bar { (shift)+1 } */
10885 gv_method_changed(gv);
10886 }
10887 else if (name) {
10888 if (!SvROK(gv)) {
10889 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10890 prepare_SV_for_RV((SV *)gv);
10891 SvOK_off((SV *)gv);
10892 SvROK_on(gv);
10893 }
10894 SvRV_set(gv, (SV *)cv);
10895 if (HvENAME_HEK(PL_curstash))
10896 mro_method_changed_in(PL_curstash);
10897 }
10898 }
10899 assert(cv);
10900 assert(SvREFCNT((SV*)cv) != 0);
10901
10902 if (!CvHASGV(cv)) {
10903 if (isGV(gv))
10904 CvGV_set(cv, gv);
10905 else {
10906 U32 hash;
10907 PERL_HASH(hash, name, namlen);
10908 CvNAME_HEK_set(cv, share_hek(name,
10909 name_is_utf8
10910 ? -(SSize_t)namlen
10911 : (SSize_t)namlen,
10912 hash));
10913 }
10914 CvFILE_set_from_cop(cv, PL_curcop);
10915 CvSTASH_set(cv, PL_curstash);
10916 }
10917
10918 if (ps) {
10919 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10920 if ( ps_utf8 )
10921 SvUTF8_on(MUTABLE_SV(cv));
10922 }
10923
10924 if (block) {
10925 /* If we assign an optree to a PVCV, then we've defined a
10926 * subroutine that the debugger could be able to set a breakpoint
10927 * in, so signal to pp_entereval that it should not throw away any
10928 * saved lines at scope exit. */
10929
10930 PL_breakable_sub_gen++;
10931 CvROOT(cv) = block;
10932 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10933 itself has a refcount. */
10934 CvSLABBED_off(cv);
10935 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10936 #ifdef PERL_DEBUG_READONLY_OPS
10937 slab = (OPSLAB *)CvSTART(cv);
10938 #endif
10939 S_process_optree(aTHX_ cv, block, start);
10940 }
10941
10942 attrs:
10943 if (attrs) {
10944 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10945 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10946 ? GvSTASH(CvGV(cv))
10947 : PL_curstash;
10948 if (!name)
10949 SAVEFREESV(cv);
10950 apply_attrs(stash, MUTABLE_SV(cv), attrs);
10951 if (!name)
10952 SvREFCNT_inc_simple_void_NN(cv);
10953 }
10954
10955 if (block && has_name) {
10956 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10957 SV * const tmpstr = cv_name(cv,NULL,0);
10958 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10959 GV_ADDMULTI, SVt_PVHV);
10960 HV *hv;
10961 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" LINE_Tf "-%" LINE_Tf,
10962 CopFILE(PL_curcop),
10963 (line_t)PL_subline,
10964 CopLINE(PL_curcop));
10965 (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
10966 hv = GvHVn(db_postponed);
10967 if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
10968 CV * const pcv = GvCV(db_postponed);
10969 if (pcv) {
10970 dSP;
10971 PUSHMARK(SP);
10972 XPUSHs(tmpstr);
10973 PUTBACK;
10974 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10975 }
10976 }
10977 }
10978
10979 if (name) {
10980 if (PL_parser && PL_parser->error_count)
10981 clear_special_blocks(name, gv, cv);
10982 else
10983 evanescent =
10984 process_special_blocks(floor, name, gv, cv);
10985 }
10986 }
10987 assert(cv);
10988
10989 done:
10990 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10991 if (PL_parser)
10992 PL_parser->copline = NOLINE;
10993 LEAVE_SCOPE(floor);
10994
10995 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10996 if (!evanescent) {
10997 #ifdef PERL_DEBUG_READONLY_OPS
10998 if (slab)
10999 Slab_to_ro(slab);
11000 #endif
11001 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11002 pad_add_weakref(cv);
11003 }
11004 return cv;
11005 }
11006
11007 STATIC void
S_clear_special_blocks(pTHX_ const char * const fullname,GV * const gv,CV * const cv)11008 S_clear_special_blocks(pTHX_ const char *const fullname,
11009 GV *const gv, CV *const cv) {
11010 const char *colon;
11011 const char *name;
11012
11013 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11014
11015 colon = strrchr(fullname,':');
11016 name = colon ? colon + 1 : fullname;
11017
11018 if ((*name == 'B' && strEQ(name, "BEGIN"))
11019 || (*name == 'E' && strEQ(name, "END"))
11020 || (*name == 'U' && strEQ(name, "UNITCHECK"))
11021 || (*name == 'C' && strEQ(name, "CHECK"))
11022 || (*name == 'I' && strEQ(name, "INIT"))) {
11023 if (!isGV(gv)) {
11024 (void)CvGV(cv);
11025 assert(isGV(gv));
11026 }
11027 GvCV_set(gv, NULL);
11028 SvREFCNT_dec_NN(MUTABLE_SV(cv));
11029 }
11030 }
11031
11032 /* Returns true if the sub has been freed. */
11033 STATIC bool
S_process_special_blocks(pTHX_ I32 floor,const char * const fullname,GV * const gv,CV * const cv)11034 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11035 GV *const gv,
11036 CV *const cv)
11037 {
11038 const char *const colon = strrchr(fullname,':');
11039 const char *const name = colon ? colon + 1 : fullname;
11040
11041 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11042
11043 if (*name == 'B') {
11044 if (strEQ(name, "BEGIN")) {
11045 /* can't goto a declaration, but a null statement is fine */
11046 module_install_hack: ;
11047 const I32 oldscope = PL_scopestack_ix;
11048 SV *max_nest_sv = NULL;
11049 IV max_nest_iv;
11050 dSP;
11051 (void)CvGV(cv);
11052 if (floor) LEAVE_SCOPE(floor);
11053 ENTER;
11054
11055 /* Make sure we don't recurse too deeply into BEGIN blocks,
11056 * but let the user control it via the new control variable
11057 *
11058 * ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}
11059 *
11060 * Note that this code (when max_nest_iv is 1) *looks* like
11061 * it would block the following code:
11062 *
11063 * BEGIN { $n |= 1; BEGIN { $n |= 2; BEGIN { $n |= 4 } } }
11064 *
11065 * but it does *not*; this code will happily execute when
11066 * the nest limit is 1. The reason is revealed in the
11067 * execution order. If we could watch $n in this code, we
11068 * would see the following order of modifications:
11069 *
11070 * $n |= 4;
11071 * $n |= 2;
11072 * $n |= 1;
11073 *
11074 * This is because nested BEGIN blocks execute in FILO
11075 * order; this is because BEGIN blocks are defined to
11076 * execute immediately once they are closed. So the
11077 * innermost block is closed first, and it executes, which
11078 * increments the eval_begin_nest_depth by 1, and then it
11079 * finishes, which drops eval_begin_nest_depth back to its
11080 * previous value. This happens in turn as each BEGIN is
11081 * completed.
11082 *
11083 * The *only* place these counts matter is when BEGIN is
11084 * inside of some kind of string eval, either a require or a
11085 * true eval. Only in that case would there be any nesting
11086 * and would perl try to execute a BEGIN before another had
11087 * completed.
11088 *
11089 * Thus this logic puts an upper limit on module nesting.
11090 * Hence the reason we let the user control it, although it
11091 * is hard to imagine a 1000-level-deep module use
11092 * dependency even in a very large codebase. The real
11093 * objective is to prevent code like this:
11094 *
11095 * perl -e'sub f { eval "BEGIN { f() }" } f()'
11096 *
11097 * from segfaulting due to stack exhaustion.
11098 *
11099 */
11100 max_nest_sv = get_sv(PERL_VAR_MAX_NESTED_EVAL_BEGIN_BLOCKS, GV_ADD);
11101 if (!SvOK(max_nest_sv))
11102 sv_setiv(max_nest_sv, PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT);
11103 max_nest_iv = SvIV(max_nest_sv);
11104 if (max_nest_iv < 0) {
11105 max_nest_iv = PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT;
11106 sv_setiv(max_nest_sv, max_nest_iv);
11107 }
11108
11109 /* (UV) below is just to silence a compiler warning, and should be
11110 * effectively a no-op, as max_nest_iv will never be negative here.
11111 */
11112 if (PL_eval_begin_nest_depth >= (UV)max_nest_iv) {
11113 Perl_croak(aTHX_ "Too many nested BEGIN blocks, maximum of %" IVdf " allowed",
11114 max_nest_iv);
11115 }
11116 SAVEINT(PL_eval_begin_nest_depth);
11117 PL_eval_begin_nest_depth++;
11118
11119 SAVEVPTR(PL_curcop);
11120 if (PL_curcop == &PL_compiling) {
11121 /* Avoid pushing the "global" &PL_compiling onto the
11122 * context stack. For example, a stack trace inside
11123 * nested use's would show all calls coming from whoever
11124 * most recently updated PL_compiling.cop_file and
11125 * cop_line. So instead, temporarily set PL_curcop to a
11126 * private copy of &PL_compiling. PL_curcop will soon be
11127 * set to point back to &PL_compiling anyway but only
11128 * after the temp value has been pushed onto the context
11129 * stack as blk_oldcop.
11130 * This is slightly hacky, but necessary. Note also
11131 * that in the brief window before PL_curcop is set back
11132 * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
11133 * will give the wrong answer.
11134 */
11135 PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL);
11136 CopLINE_set(PL_curcop, CopLINE(&PL_compiling));
11137 SAVEFREEOP(PL_curcop);
11138 }
11139
11140 PUSHSTACKi(PERLSI_REQUIRE);
11141 SAVECOPFILE(&PL_compiling);
11142 SAVECOPLINE(&PL_compiling);
11143
11144 DEBUG_x( dump_sub(gv) );
11145 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11146 GvCV_set(gv,0); /* cv has been hijacked */
11147 call_list(oldscope, PL_beginav);
11148
11149 POPSTACK;
11150 LEAVE;
11151 return !PL_savebegin;
11152 }
11153 else
11154 return FALSE;
11155 } else {
11156 if (*name == 'E') {
11157 if (strEQ(name, "END")) {
11158 DEBUG_x( dump_sub(gv) );
11159 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11160 } else
11161 return FALSE;
11162 } else if (*name == 'U') {
11163 if (strEQ(name, "UNITCHECK")) {
11164 /* It's never too late to run a unitcheck block */
11165 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11166 }
11167 else
11168 return FALSE;
11169 } else if (*name == 'C') {
11170 if (strEQ(name, "CHECK")) {
11171 if (PL_main_start)
11172 /* diag_listed_as: Too late to run %s block */
11173 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11174 "Too late to run CHECK block");
11175 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11176 }
11177 else
11178 return FALSE;
11179 } else if (*name == 'I') {
11180 if (strEQ(name, "INIT")) {
11181 #ifdef MI_INIT_WORKAROUND_PACK
11182 {
11183 HV *hv = CvSTASH(cv);
11184 STRLEN len = hv ? HvNAMELEN(hv) : 0;
11185 char *pv = (len == sizeof(MI_INIT_WORKAROUND_PACK)-1)
11186 ? HvNAME_get(hv) : NULL;
11187 if ( pv && strEQ(pv, MI_INIT_WORKAROUND_PACK) ) {
11188 /* old versions of Module::Install::DSL contain code
11189 * that creates an INIT in eval, which expects to run
11190 * after an exit(0) in BEGIN. This unfortunately
11191 * breaks a lot of code in the CPAN river. So we magically
11192 * convert INIT blocks from Module::Install::DSL to
11193 * be BEGIN blocks. Which works out, since the INIT
11194 * blocks it creates are eval'ed and so are late.
11195 */
11196 Perl_warn(aTHX_ "Treating %s::INIT block as BEGIN block as workaround",
11197 MI_INIT_WORKAROUND_PACK);
11198 goto module_install_hack;
11199 }
11200
11201 }
11202 #endif
11203 if (PL_main_start)
11204 /* diag_listed_as: Too late to run %s block */
11205 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11206 "Too late to run INIT block");
11207 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11208 }
11209 else
11210 return FALSE;
11211 } else
11212 return FALSE;
11213 DEBUG_x( dump_sub(gv) );
11214 (void)CvGV(cv);
11215 GvCV_set(gv,0); /* cv has been hijacked */
11216 return FALSE;
11217 }
11218 }
11219
11220 /*
11221 =for apidoc newCONSTSUB
11222
11223 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11224 rather than of counted length, and no flags are set. (This means that
11225 C<name> is always interpreted as Latin-1.)
11226
11227 =cut
11228 */
11229
11230 CV *
Perl_newCONSTSUB(pTHX_ HV * stash,const char * name,SV * sv)11231 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11232 {
11233 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11234 }
11235
11236 /*
11237 =for apidoc newCONSTSUB_flags
11238
11239 Construct a constant subroutine, also performing some surrounding
11240 jobs. A scalar constant-valued subroutine is eligible for inlining
11241 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11242 123 }>>. Other kinds of constant subroutine have other treatment.
11243
11244 The subroutine will have an empty prototype and will ignore any arguments
11245 when called. Its constant behaviour is determined by C<sv>. If C<sv>
11246 is null, the subroutine will yield an empty list. If C<sv> points to a
11247 scalar, the subroutine will always yield that scalar. If C<sv> points
11248 to an array, the subroutine will always yield a list of the elements of
11249 that array in list context, or the number of elements in the array in
11250 scalar context. This function takes ownership of one counted reference
11251 to the scalar or array, and will arrange for the object to live as long
11252 as the subroutine does. If C<sv> points to a scalar then the inlining
11253 assumes that the value of the scalar will never change, so the caller
11254 must ensure that the scalar is not subsequently written to. If C<sv>
11255 points to an array then no such assumption is made, so it is ostensibly
11256 safe to mutate the array or its elements, but whether this is really
11257 supported has not been determined.
11258
11259 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11260 Other aspects of the subroutine will be left in their default state.
11261 The caller is free to mutate the subroutine beyond its initial state
11262 after this function has returned.
11263
11264 If C<name> is null then the subroutine will be anonymous, with its
11265 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11266 subroutine will be named accordingly, referenced by the appropriate glob.
11267 C<name> is a string of length C<len> bytes giving a sigilless symbol
11268 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11269 otherwise. The name may be either qualified or unqualified. If the
11270 name is unqualified then it defaults to being in the stash specified by
11271 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11272 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11273 semantics.
11274
11275 C<flags> should not have bits set other than C<SVf_UTF8>.
11276
11277 If there is already a subroutine of the specified name, then the new sub
11278 will replace the existing one in the glob. A warning may be generated
11279 about the redefinition.
11280
11281 If the subroutine has one of a few special names, such as C<BEGIN> or
11282 C<END>, then it will be claimed by the appropriate queue for automatic
11283 running of phase-related subroutines. In this case the relevant glob will
11284 be left not containing any subroutine, even if it did contain one before.
11285 Execution of the subroutine will likely be a no-op, unless C<sv> was
11286 a tied array or the caller modified the subroutine in some interesting
11287 way before it was executed. In the case of C<BEGIN>, the treatment is
11288 buggy: the sub will be executed when only half built, and may be deleted
11289 prematurely, possibly causing a crash.
11290
11291 The function returns a pointer to the constructed subroutine. If the sub
11292 is anonymous then ownership of one counted reference to the subroutine
11293 is transferred to the caller. If the sub is named then the caller does
11294 not get ownership of a reference. In most such cases, where the sub
11295 has a non-phase name, the sub will be alive at the point it is returned
11296 by virtue of being contained in the glob that names it. A phase-named
11297 subroutine will usually be alive by virtue of the reference owned by
11298 the phase's automatic run queue. A C<BEGIN> subroutine may have been
11299 destroyed already by the time this function returns, but currently bugs
11300 occur in that case before the caller gets control. It is the caller's
11301 responsibility to ensure that it knows which of these situations applies.
11302
11303 =cut
11304 */
11305
11306 CV *
Perl_newCONSTSUB_flags(pTHX_ HV * stash,const char * name,STRLEN len,U32 flags,SV * sv)11307 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11308 U32 flags, SV *sv)
11309 {
11310 CV* cv;
11311 const char *const file = CopFILE(PL_curcop);
11312
11313 ENTER;
11314
11315 if (IN_PERL_RUNTIME) {
11316 /* at runtime, it's not safe to manipulate PL_curcop: it may be
11317 * an op shared between threads. Use a non-shared COP for our
11318 * dirty work */
11319 SAVEVPTR(PL_curcop);
11320 SAVECOMPILEWARNINGS();
11321 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11322 PL_curcop = &PL_compiling;
11323 }
11324 SAVECOPLINE(PL_curcop);
11325 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11326
11327 SAVEHINTS();
11328 PL_hints &= ~HINT_BLOCK_SCOPE;
11329
11330 if (stash) {
11331 SAVEGENERICSV(PL_curstash);
11332 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11333 }
11334
11335 /* Protect sv against leakage caused by fatal warnings. */
11336 if (sv) SAVEFREESV(sv);
11337
11338 /* file becomes the CvFILE. For an XS, it's usually static storage,
11339 and so doesn't get free()d. (It's expected to be from the C pre-
11340 processor __FILE__ directive). But we need a dynamically allocated one,
11341 and we need it to get freed. */
11342 cv = newXS_len_flags(name, len,
11343 sv && SvTYPE(sv) == SVt_PVAV
11344 ? const_av_xsub
11345 : const_sv_xsub,
11346 file ? file : "", "",
11347 &sv, XS_DYNAMIC_FILENAME | flags);
11348 assert(cv);
11349 assert(SvREFCNT((SV*)cv) != 0);
11350 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11351 CvCONST_on(cv);
11352
11353 LEAVE;
11354
11355 return cv;
11356 }
11357
11358 /*
11359 =for apidoc newXS
11360
11361 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
11362 static storage, as it is used directly as CvFILE(), without a copy being made.
11363
11364 =cut
11365 */
11366
11367 CV *
Perl_newXS(pTHX_ const char * name,XSUBADDR_t subaddr,const char * filename)11368 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11369 {
11370 PERL_ARGS_ASSERT_NEWXS;
11371 return newXS_len_flags(
11372 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11373 );
11374 }
11375
11376 CV *
Perl_newXS_flags(pTHX_ const char * name,XSUBADDR_t subaddr,const char * const filename,const char * const proto,U32 flags)11377 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11378 const char *const filename, const char *const proto,
11379 U32 flags)
11380 {
11381 PERL_ARGS_ASSERT_NEWXS_FLAGS;
11382 return newXS_len_flags(
11383 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11384 );
11385 }
11386
11387 CV *
Perl_newXS_deffile(pTHX_ const char * name,XSUBADDR_t subaddr)11388 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11389 {
11390 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11391 return newXS_len_flags(
11392 name, strlen(name), subaddr, NULL, NULL, NULL, 0
11393 );
11394 }
11395
11396 /*
11397 =for apidoc newXS_len_flags
11398
11399 Construct an XS subroutine, also performing some surrounding jobs.
11400
11401 The subroutine will have the entry point C<subaddr>. It will have
11402 the prototype specified by the nul-terminated string C<proto>, or
11403 no prototype if C<proto> is null. The prototype string is copied;
11404 the caller can mutate the supplied string afterwards. If C<filename>
11405 is non-null, it must be a nul-terminated filename, and the subroutine
11406 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
11407 point directly to the supplied string, which must be static. If C<flags>
11408 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11409 be taken instead.
11410
11411 Other aspects of the subroutine will be left in their default state.
11412 If anything else needs to be done to the subroutine for it to function
11413 correctly, it is the caller's responsibility to do that after this
11414 function has constructed it. However, beware of the subroutine
11415 potentially being destroyed before this function returns, as described
11416 below.
11417
11418 If C<name> is null then the subroutine will be anonymous, with its
11419 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11420 subroutine will be named accordingly, referenced by the appropriate glob.
11421 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11422 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11423 The name may be either qualified or unqualified, with the stash defaulting
11424 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
11425 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11426 they have there, such as C<GV_ADDWARN>. The symbol is always added to
11427 the stash if necessary, with C<GV_ADDMULTI> semantics.
11428
11429 If there is already a subroutine of the specified name, then the new sub
11430 will replace the existing one in the glob. A warning may be generated
11431 about the redefinition. If the old subroutine was C<CvCONST> then the
11432 decision about whether to warn is influenced by an expectation about
11433 whether the new subroutine will become a constant of similar value.
11434 That expectation is determined by C<const_svp>. (Note that the call to
11435 this function doesn't make the new subroutine C<CvCONST> in any case;
11436 that is left to the caller.) If C<const_svp> is null then it indicates
11437 that the new subroutine will not become a constant. If C<const_svp>
11438 is non-null then it indicates that the new subroutine will become a
11439 constant, and it points to an C<SV*> that provides the constant value
11440 that the subroutine will have.
11441
11442 If the subroutine has one of a few special names, such as C<BEGIN> or
11443 C<END>, then it will be claimed by the appropriate queue for automatic
11444 running of phase-related subroutines. In this case the relevant glob will
11445 be left not containing any subroutine, even if it did contain one before.
11446 In the case of C<BEGIN>, the subroutine will be executed and the reference
11447 to it disposed of before this function returns, and also before its
11448 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
11449 constructed by this function to be ready for execution then the caller
11450 must prevent this happening by giving the subroutine a different name.
11451
11452 The function returns a pointer to the constructed subroutine. If the sub
11453 is anonymous then ownership of one counted reference to the subroutine
11454 is transferred to the caller. If the sub is named then the caller does
11455 not get ownership of a reference. In most such cases, where the sub
11456 has a non-phase name, the sub will be alive at the point it is returned
11457 by virtue of being contained in the glob that names it. A phase-named
11458 subroutine will usually be alive by virtue of the reference owned by the
11459 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11460 been executed, will quite likely have been destroyed already by the
11461 time this function returns, making it erroneous for the caller to make
11462 any use of the returned pointer. It is the caller's responsibility to
11463 ensure that it knows which of these situations applies.
11464
11465 =cut
11466 */
11467
11468 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)11469 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
11470 XSUBADDR_t subaddr, const char *const filename,
11471 const char *const proto, SV **const_svp,
11472 U32 flags)
11473 {
11474 CV *cv;
11475 bool interleave = FALSE;
11476 bool evanescent = FALSE;
11477
11478 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
11479
11480 {
11481 GV * const gv = gv_fetchpvn(
11482 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11483 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
11484 sizeof("__ANON__::__ANON__") - 1,
11485 GV_ADDMULTI | flags, SVt_PVCV);
11486
11487 if ((cv = (name ? GvCV(gv) : NULL))) {
11488 if (GvCVGEN(gv)) {
11489 /* just a cached method */
11490 SvREFCNT_dec(cv);
11491 cv = NULL;
11492 }
11493 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
11494 /* already defined (or promised) */
11495 /* Redundant check that allows us to avoid creating an SV
11496 most of the time: */
11497 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11498 report_redefined_cv(newSVpvn_flags(
11499 name,len,(flags&SVf_UTF8)|SVs_TEMP
11500 ),
11501 cv, const_svp);
11502 }
11503 interleave = TRUE;
11504 ENTER;
11505 SAVEFREESV(cv);
11506 cv = NULL;
11507 }
11508 }
11509
11510 if (cv) /* must reuse cv if autoloaded */
11511 cv_undef(cv);
11512 else {
11513 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11514 if (name) {
11515 GvCV_set(gv,cv);
11516 GvCVGEN(gv) = 0;
11517 if (HvENAME_HEK(GvSTASH(gv)))
11518 gv_method_changed(gv); /* newXS */
11519 }
11520 }
11521 assert(cv);
11522 assert(SvREFCNT((SV*)cv) != 0);
11523
11524 CvGV_set(cv, gv);
11525 if(filename) {
11526 /* XSUBs can't be perl lang/perl5db.pl debugged
11527 if (PERLDB_LINE_OR_SAVESRC)
11528 (void)gv_fetchfile(filename); */
11529 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
11530 if (flags & XS_DYNAMIC_FILENAME) {
11531 CvDYNFILE_on(cv);
11532 CvFILE(cv) = savepv(filename);
11533 } else {
11534 /* NOTE: not copied, as it is expected to be an external constant string */
11535 CvFILE(cv) = (char *)filename;
11536 }
11537 } else {
11538 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
11539 CvFILE(cv) = (char*)PL_xsubfilename;
11540 }
11541 CvISXSUB_on(cv);
11542 CvXSUB(cv) = subaddr;
11543 #ifndef MULTIPLICITY
11544 CvHSCXT(cv) = &PL_stack_sp;
11545 #else
11546 PoisonPADLIST(cv);
11547 #endif
11548
11549 if (name)
11550 evanescent = process_special_blocks(0, name, gv, cv);
11551 else
11552 CvANON_on(cv);
11553 } /* <- not a conditional branch */
11554
11555 assert(cv);
11556 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11557
11558 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
11559 if (interleave) LEAVE;
11560 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11561 return cv;
11562 }
11563
11564 /* Add a stub CV to a typeglob.
11565 * This is the implementation of a forward declaration, 'sub foo';'
11566 */
11567
11568 CV *
Perl_newSTUB(pTHX_ GV * gv,bool fake)11569 Perl_newSTUB(pTHX_ GV *gv, bool fake)
11570 {
11571 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11572 GV *cvgv;
11573 PERL_ARGS_ASSERT_NEWSTUB;
11574 assert(!GvCVu(gv));
11575 GvCV_set(gv, cv);
11576 GvCVGEN(gv) = 0;
11577 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
11578 gv_method_changed(gv);
11579 if (SvFAKE(gv)) {
11580 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
11581 SvFAKE_off(cvgv);
11582 }
11583 else cvgv = gv;
11584 CvGV_set(cv, cvgv);
11585 CvFILE_set_from_cop(cv, PL_curcop);
11586 CvSTASH_set(cv, PL_curstash);
11587 GvMULTI_on(gv);
11588 return cv;
11589 }
11590
11591 void
Perl_newFORM(pTHX_ I32 floor,OP * o,OP * block)11592 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
11593 {
11594 CV *cv;
11595 GV *gv;
11596 OP *root;
11597 OP *start;
11598
11599 if (PL_parser && PL_parser->error_count) {
11600 op_free(block);
11601 goto finish;
11602 }
11603
11604 gv = o
11605 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
11606 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
11607
11608 GvMULTI_on(gv);
11609 if ((cv = GvFORM(gv))) {
11610 if (ckWARN(WARN_REDEFINE)) {
11611 const line_t oldline = CopLINE(PL_curcop);
11612 if (PL_parser && PL_parser->copline != NOLINE)
11613 CopLINE_set(PL_curcop, PL_parser->copline);
11614 if (o) {
11615 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11616 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
11617 } else {
11618 /* diag_listed_as: Format %s redefined */
11619 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11620 "Format STDOUT redefined");
11621 }
11622 CopLINE_set(PL_curcop, oldline);
11623 }
11624 SvREFCNT_dec(cv);
11625 }
11626 cv = PL_compcv;
11627 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
11628 CvGV_set(cv, gv);
11629 CvFILE_set_from_cop(cv, PL_curcop);
11630
11631
11632 root = newUNOP(OP_LEAVEWRITE, 0, voidnonfinal(block));
11633 CvROOT(cv) = root;
11634 start = LINKLIST(root);
11635 root->op_next = 0;
11636 S_process_optree(aTHX_ cv, root, start);
11637 cv_forget_slab(cv);
11638
11639 finish:
11640 op_free(o);
11641 if (PL_parser)
11642 PL_parser->copline = NOLINE;
11643 LEAVE_SCOPE(floor);
11644 PL_compiling.cop_seq = 0;
11645 }
11646
11647 OP *
Perl_newANONLIST(pTHX_ OP * o)11648 Perl_newANONLIST(pTHX_ OP *o)
11649 {
11650 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
11651 }
11652
11653 OP *
Perl_newANONHASH(pTHX_ OP * o)11654 Perl_newANONHASH(pTHX_ OP *o)
11655 {
11656 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
11657 }
11658
11659 OP *
Perl_newANONSUB(pTHX_ I32 floor,OP * proto,OP * block)11660 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
11661 {
11662 return newANONATTRSUB(floor, proto, NULL, block);
11663 }
11664
11665 OP *
Perl_newANONATTRSUB(pTHX_ I32 floor,OP * proto,OP * attrs,OP * block)11666 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
11667 {
11668 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
11669
11670 bool is_const = CvANONCONST(cv);
11671
11672 OP * anoncode =
11673 newSVOP(OP_ANONCODE, is_const ? 0 : OPf_REF,
11674 cv);
11675
11676 if (is_const) {
11677 anoncode = newUNOP(OP_ANONCONST, OPf_REF,
11678 op_convert_list(OP_ENTERSUB,
11679 OPf_STACKED|OPf_WANT_SCALAR,
11680 anoncode));
11681 }
11682
11683 return anoncode;
11684 }
11685
11686 OP *
Perl_oopsAV(pTHX_ OP * o)11687 Perl_oopsAV(pTHX_ OP *o)
11688 {
11689
11690 PERL_ARGS_ASSERT_OOPSAV;
11691
11692 switch (o->op_type) {
11693 case OP_PADSV:
11694 case OP_PADHV:
11695 OpTYPE_set(o, OP_PADAV);
11696 return ref(o, OP_RV2AV);
11697
11698 case OP_RV2SV:
11699 case OP_RV2HV:
11700 OpTYPE_set(o, OP_RV2AV);
11701 ref(o, OP_RV2AV);
11702 break;
11703
11704 default:
11705 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11706 break;
11707 }
11708 return o;
11709 }
11710
11711 OP *
Perl_oopsHV(pTHX_ OP * o)11712 Perl_oopsHV(pTHX_ OP *o)
11713 {
11714
11715 PERL_ARGS_ASSERT_OOPSHV;
11716
11717 switch (o->op_type) {
11718 case OP_PADSV:
11719 case OP_PADAV:
11720 OpTYPE_set(o, OP_PADHV);
11721 return ref(o, OP_RV2HV);
11722
11723 case OP_RV2SV:
11724 case OP_RV2AV:
11725 OpTYPE_set(o, OP_RV2HV);
11726 /* rv2hv steals the bottom bit for its own uses */
11727 o->op_private &= ~OPpARG1_MASK;
11728 ref(o, OP_RV2HV);
11729 break;
11730
11731 default:
11732 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11733 break;
11734 }
11735 return o;
11736 }
11737
11738 OP *
Perl_newAVREF(pTHX_ OP * o)11739 Perl_newAVREF(pTHX_ OP *o)
11740 {
11741
11742 PERL_ARGS_ASSERT_NEWAVREF;
11743
11744 if (o->op_type == OP_PADANY) {
11745 OpTYPE_set(o, OP_PADAV);
11746 return o;
11747 }
11748 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11749 Perl_croak(aTHX_ "Can't use an array as a reference");
11750 }
11751 return newUNOP(OP_RV2AV, 0, scalar(o));
11752 }
11753
11754 OP *
Perl_newGVREF(pTHX_ I32 type,OP * o)11755 Perl_newGVREF(pTHX_ I32 type, OP *o)
11756 {
11757 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11758 return newUNOP(OP_NULL, 0, o);
11759
11760 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED &&
11761 ((PL_opargs[type] >> OASHIFT) & 7) == OA_FILEREF &&
11762 o->op_type == OP_CONST && (o->op_private & OPpCONST_BARE)) {
11763 no_bareword_filehandle(SvPVX(cSVOPo_sv));
11764 }
11765
11766 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11767 }
11768
11769 OP *
Perl_newHVREF(pTHX_ OP * o)11770 Perl_newHVREF(pTHX_ OP *o)
11771 {
11772
11773 PERL_ARGS_ASSERT_NEWHVREF;
11774
11775 if (o->op_type == OP_PADANY) {
11776 OpTYPE_set(o, OP_PADHV);
11777 return o;
11778 }
11779 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11780 Perl_croak(aTHX_ "Can't use a hash as a reference");
11781 }
11782 return newUNOP(OP_RV2HV, 0, scalar(o));
11783 }
11784
11785 OP *
Perl_newCVREF(pTHX_ I32 flags,OP * o)11786 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11787 {
11788 if (o->op_type == OP_PADANY) {
11789 OpTYPE_set(o, OP_PADCV);
11790 }
11791 return newUNOP(OP_RV2CV, flags, scalar(o));
11792 }
11793
11794 OP *
Perl_newSVREF(pTHX_ OP * o)11795 Perl_newSVREF(pTHX_ OP *o)
11796 {
11797
11798 PERL_ARGS_ASSERT_NEWSVREF;
11799
11800 if (o->op_type == OP_PADANY) {
11801 OpTYPE_set(o, OP_PADSV);
11802 scalar(o);
11803 return o;
11804 }
11805 return newUNOP(OP_RV2SV, 0, scalar(o));
11806 }
11807
11808 /* Check routines. See the comments at the top of this file for details
11809 * on when these are called */
11810
11811 OP *
Perl_ck_anoncode(pTHX_ OP * o)11812 Perl_ck_anoncode(pTHX_ OP *o)
11813 {
11814 PERL_ARGS_ASSERT_CK_ANONCODE;
11815
11816 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11817 cSVOPo->op_sv = NULL;
11818 return o;
11819 }
11820
11821 static void
S_io_hints(pTHX_ OP * o)11822 S_io_hints(pTHX_ OP *o)
11823 {
11824 #if O_BINARY != 0 || O_TEXT != 0
11825 HV * const table =
11826 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11827 if (table) {
11828 SV **svp = hv_fetchs(table, "open_IN", FALSE);
11829 if (svp && *svp) {
11830 STRLEN len = 0;
11831 const char *d = SvPV_const(*svp, len);
11832 const I32 mode = mode_from_discipline(d, len);
11833 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11834 # if O_BINARY != 0
11835 if (mode & O_BINARY)
11836 o->op_private |= OPpOPEN_IN_RAW;
11837 # endif
11838 # if O_TEXT != 0
11839 if (mode & O_TEXT)
11840 o->op_private |= OPpOPEN_IN_CRLF;
11841 # endif
11842 }
11843
11844 svp = hv_fetchs(table, "open_OUT", FALSE);
11845 if (svp && *svp) {
11846 STRLEN len = 0;
11847 const char *d = SvPV_const(*svp, len);
11848 const I32 mode = mode_from_discipline(d, len);
11849 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11850 # if O_BINARY != 0
11851 if (mode & O_BINARY)
11852 o->op_private |= OPpOPEN_OUT_RAW;
11853 # endif
11854 # if O_TEXT != 0
11855 if (mode & O_TEXT)
11856 o->op_private |= OPpOPEN_OUT_CRLF;
11857 # endif
11858 }
11859 }
11860 #else
11861 PERL_UNUSED_CONTEXT;
11862 PERL_UNUSED_ARG(o);
11863 #endif
11864 }
11865
11866 OP *
Perl_ck_backtick(pTHX_ OP * o)11867 Perl_ck_backtick(pTHX_ OP *o)
11868 {
11869 GV *gv;
11870 OP *newop = NULL;
11871 OP *sibl;
11872 PERL_ARGS_ASSERT_CK_BACKTICK;
11873 o = ck_fun(o);
11874 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11875 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11876 && (gv = gv_override("readpipe",8)))
11877 {
11878 /* detach rest of siblings from o and its first child */
11879 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11880 newop = S_new_entersubop(aTHX_ gv, sibl);
11881 }
11882 else if (!(o->op_flags & OPf_KIDS))
11883 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11884 if (newop) {
11885 op_free(o);
11886 return newop;
11887 }
11888 S_io_hints(aTHX_ o);
11889 return o;
11890 }
11891
11892 OP *
Perl_ck_bitop(pTHX_ OP * o)11893 Perl_ck_bitop(pTHX_ OP *o)
11894 {
11895 PERL_ARGS_ASSERT_CK_BITOP;
11896
11897 /* get rid of arg count and indicate if in the scope of 'use integer' */
11898 o->op_private = (PL_hints & HINT_INTEGER) ? OPpUSEINT : 0;
11899
11900 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11901 && OP_IS_INFIX_BIT(o->op_type))
11902 {
11903 const OP * const left = cBINOPo->op_first;
11904 const OP * const right = OpSIBLING(left);
11905 if ((OP_IS_NUMCOMPARE(left->op_type) &&
11906 (left->op_flags & OPf_PARENS) == 0) ||
11907 (OP_IS_NUMCOMPARE(right->op_type) &&
11908 (right->op_flags & OPf_PARENS) == 0))
11909 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11910 "Possible precedence problem on bitwise %s operator",
11911 o->op_type == OP_BIT_OR
11912 ||o->op_type == OP_NBIT_OR ? "|"
11913 : o->op_type == OP_BIT_AND
11914 ||o->op_type == OP_NBIT_AND ? "&"
11915 : o->op_type == OP_BIT_XOR
11916 ||o->op_type == OP_NBIT_XOR ? "^"
11917 : o->op_type == OP_SBIT_OR ? "|."
11918 : o->op_type == OP_SBIT_AND ? "&." : "^."
11919 );
11920 }
11921 return o;
11922 }
11923
11924 PERL_STATIC_INLINE bool
is_dollar_bracket(pTHX_ const OP * const o)11925 is_dollar_bracket(pTHX_ const OP * const o)
11926 {
11927 const OP *kid;
11928 PERL_UNUSED_CONTEXT;
11929 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11930 && (kid = cUNOPx(o)->op_first)
11931 && kid->op_type == OP_GV
11932 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11933 }
11934
11935 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11936
11937 OP *
Perl_ck_cmp(pTHX_ OP * o)11938 Perl_ck_cmp(pTHX_ OP *o)
11939 {
11940 bool is_eq;
11941 bool neg;
11942 bool reverse;
11943 bool iv0;
11944 OP *indexop, *constop, *start;
11945 SV *sv;
11946 IV iv;
11947
11948 PERL_ARGS_ASSERT_CK_CMP;
11949
11950 is_eq = ( o->op_type == OP_EQ
11951 || o->op_type == OP_NE
11952 || o->op_type == OP_I_EQ
11953 || o->op_type == OP_I_NE);
11954
11955 if (!is_eq && ckWARN(WARN_SYNTAX)) {
11956 const OP *kid = cUNOPo->op_first;
11957 if (kid &&
11958 (
11959 ( is_dollar_bracket(aTHX_ kid)
11960 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11961 )
11962 || ( kid->op_type == OP_CONST
11963 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11964 )
11965 )
11966 )
11967 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11968 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11969 }
11970
11971 /* convert (index(...) == -1) and variations into
11972 * (r)index/BOOL(,NEG)
11973 */
11974
11975 reverse = FALSE;
11976
11977 indexop = cUNOPo->op_first;
11978 constop = OpSIBLING(indexop);
11979 start = NULL;
11980 if (indexop->op_type == OP_CONST) {
11981 constop = indexop;
11982 indexop = OpSIBLING(constop);
11983 start = constop;
11984 reverse = TRUE;
11985 }
11986
11987 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11988 return o;
11989
11990 /* ($lex = index(....)) == -1 */
11991 if (indexop->op_private & OPpTARGET_MY)
11992 return o;
11993
11994 if (constop->op_type != OP_CONST)
11995 return o;
11996
11997 sv = cSVOPx_sv(constop);
11998 if (!(sv && SvIOK_notUV(sv)))
11999 return o;
12000
12001 iv = SvIVX(sv);
12002 if (iv != -1 && iv != 0)
12003 return o;
12004 iv0 = (iv == 0);
12005
12006 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12007 if (!(iv0 ^ reverse))
12008 return o;
12009 neg = iv0;
12010 }
12011 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12012 if (iv0 ^ reverse)
12013 return o;
12014 neg = !iv0;
12015 }
12016 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12017 if (!(iv0 ^ reverse))
12018 return o;
12019 neg = !iv0;
12020 }
12021 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12022 if (iv0 ^ reverse)
12023 return o;
12024 neg = iv0;
12025 }
12026 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12027 if (iv0)
12028 return o;
12029 neg = TRUE;
12030 }
12031 else {
12032 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12033 if (iv0)
12034 return o;
12035 neg = FALSE;
12036 }
12037
12038 indexop->op_flags &= ~OPf_PARENS;
12039 indexop->op_flags |= (o->op_flags & OPf_PARENS);
12040 indexop->op_private |= OPpTRUEBOOL;
12041 if (neg)
12042 indexop->op_private |= OPpINDEX_BOOLNEG;
12043 /* cut out the index op and free the eq,const ops */
12044 (void)op_sibling_splice(o, start, 1, NULL);
12045 op_free(o);
12046
12047 return indexop;
12048 }
12049
12050
12051 OP *
Perl_ck_concat(pTHX_ OP * o)12052 Perl_ck_concat(pTHX_ OP *o)
12053 {
12054 const OP * const kid = cUNOPo->op_first;
12055
12056 PERL_ARGS_ASSERT_CK_CONCAT;
12057 PERL_UNUSED_CONTEXT;
12058
12059 /* reuse the padtmp returned by the concat child */
12060 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12061 !(kUNOP->op_first->op_flags & OPf_MOD))
12062 {
12063 o->op_flags |= OPf_STACKED;
12064 o->op_private |= OPpCONCAT_NESTED;
12065 }
12066 return o;
12067 }
12068
12069 OP *
Perl_ck_spair(pTHX_ OP * o)12070 Perl_ck_spair(pTHX_ OP *o)
12071 {
12072
12073 PERL_ARGS_ASSERT_CK_SPAIR;
12074
12075 if (o->op_flags & OPf_KIDS) {
12076 OP* newop;
12077 OP* kid;
12078 OP* kidkid;
12079 const OPCODE type = o->op_type;
12080 o = modkids(ck_fun(o), type);
12081 kid = cUNOPo->op_first;
12082 kidkid = kUNOP->op_first;
12083 newop = OpSIBLING(kidkid);
12084 if (newop) {
12085 const OPCODE type = newop->op_type;
12086 if (OpHAS_SIBLING(newop))
12087 return o;
12088 if (o->op_type == OP_REFGEN
12089 && ( type == OP_RV2CV
12090 || ( !(newop->op_flags & OPf_PARENS)
12091 && ( type == OP_RV2AV || type == OP_PADAV
12092 || type == OP_RV2HV || type == OP_PADHV))))
12093 NOOP; /* OK (allow srefgen for \@a and \%h) */
12094 else if (OP_GIMME(newop,0) != G_SCALAR)
12095 return o;
12096 }
12097 /* excise first sibling */
12098 op_sibling_splice(kid, NULL, 1, NULL);
12099 op_free(kidkid);
12100 }
12101 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12102 * and OP_CHOMP into OP_SCHOMP */
12103 o->op_ppaddr = PL_ppaddr[++o->op_type];
12104 return ck_fun(o);
12105 }
12106
12107 OP *
Perl_ck_delete(pTHX_ OP * o)12108 Perl_ck_delete(pTHX_ OP *o)
12109 {
12110 PERL_ARGS_ASSERT_CK_DELETE;
12111
12112 o = ck_fun(o);
12113 o->op_private = 0;
12114 if (o->op_flags & OPf_KIDS) {
12115 OP * const kid = cUNOPo->op_first;
12116 switch (kid->op_type) {
12117 case OP_ASLICE:
12118 o->op_flags |= OPf_SPECIAL;
12119 /* FALLTHROUGH */
12120 case OP_HSLICE:
12121 o->op_private |= OPpSLICE;
12122 break;
12123 case OP_AELEM:
12124 o->op_flags |= OPf_SPECIAL;
12125 /* FALLTHROUGH */
12126 case OP_HELEM:
12127 break;
12128 case OP_KVASLICE:
12129 o->op_flags |= OPf_SPECIAL;
12130 /* FALLTHROUGH */
12131 case OP_KVHSLICE:
12132 o->op_private |= OPpKVSLICE;
12133 break;
12134 default:
12135 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12136 "element or slice");
12137 }
12138 if (kid->op_private & OPpLVAL_INTRO)
12139 o->op_private |= OPpLVAL_INTRO;
12140 op_null(kid);
12141 }
12142 return o;
12143 }
12144
12145 OP *
Perl_ck_eof(pTHX_ OP * o)12146 Perl_ck_eof(pTHX_ OP *o)
12147 {
12148 PERL_ARGS_ASSERT_CK_EOF;
12149
12150 if (o->op_flags & OPf_KIDS) {
12151 OP *kid;
12152 if (cLISTOPo->op_first->op_type == OP_STUB) {
12153 OP * const newop
12154 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12155 op_free(o);
12156 o = newop;
12157 }
12158 o = ck_fun(o);
12159 kid = cLISTOPo->op_first;
12160 if (kid->op_type == OP_RV2GV)
12161 kid->op_private |= OPpALLOW_FAKE;
12162 }
12163 return o;
12164 }
12165
12166
12167 OP *
Perl_ck_eval(pTHX_ OP * o)12168 Perl_ck_eval(pTHX_ OP *o)
12169 {
12170
12171 PERL_ARGS_ASSERT_CK_EVAL;
12172
12173 PL_hints |= HINT_BLOCK_SCOPE;
12174 if (o->op_flags & OPf_KIDS) {
12175 SVOP * const kid = cSVOPx(cUNOPo->op_first);
12176 assert(kid);
12177
12178 if (o->op_type == OP_ENTERTRY) {
12179 LOGOP *enter;
12180
12181 /* cut whole sibling chain free from o */
12182 op_sibling_splice(o, NULL, -1, NULL);
12183 op_free(o);
12184
12185 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12186
12187 /* establish postfix order */
12188 enter->op_next = (OP*)enter;
12189
12190 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12191 OpTYPE_set(o, OP_LEAVETRY);
12192 enter->op_other = o;
12193 return o;
12194 }
12195 else {
12196 scalar((OP*)kid);
12197 S_set_haseval(aTHX);
12198 }
12199 }
12200 else {
12201 const U8 priv = o->op_private;
12202 op_free(o);
12203 /* the newUNOP will recursively call ck_eval(), which will handle
12204 * all the stuff at the end of this function, like adding
12205 * OP_HINTSEVAL
12206 */
12207 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12208 }
12209 o->op_targ = (PADOFFSET)PL_hints;
12210 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12211 if ((PL_hints & HINT_LOCALIZE_HH) != 0
12212 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12213 /* Store a copy of %^H that pp_entereval can pick up. */
12214 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12215 OP *hhop;
12216 STOREFEATUREBITSHH(hh);
12217 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12218 /* append hhop to only child */
12219 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12220
12221 o->op_private |= OPpEVAL_HAS_HH;
12222 }
12223 if (!(o->op_private & OPpEVAL_BYTES)
12224 && FEATURE_UNIEVAL_IS_ENABLED)
12225 o->op_private |= OPpEVAL_UNICODE;
12226 return o;
12227 }
12228
12229 OP *
Perl_ck_trycatch(pTHX_ OP * o)12230 Perl_ck_trycatch(pTHX_ OP *o)
12231 {
12232 LOGOP *enter;
12233 OP *to_free = NULL;
12234 OP *trykid, *catchkid;
12235 OP *catchroot, *catchstart;
12236
12237 PERL_ARGS_ASSERT_CK_TRYCATCH;
12238
12239 trykid = cUNOPo->op_first;
12240 if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) {
12241 to_free = trykid;
12242 trykid = OpSIBLING(trykid);
12243 }
12244 catchkid = OpSIBLING(trykid);
12245
12246 assert(trykid->op_type == OP_POPTRY);
12247 assert(catchkid->op_type == OP_CATCH);
12248
12249 /* cut whole sibling chain free from o */
12250 op_sibling_splice(o, NULL, -1, NULL);
12251 if(to_free)
12252 op_free(to_free);
12253 op_free(o);
12254
12255 enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL);
12256
12257 /* establish postfix order */
12258 enter->op_next = (OP*)enter;
12259
12260 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid);
12261 op_append_elem(OP_LINESEQ, (OP*)o, catchkid);
12262
12263 OpTYPE_set(o, OP_LEAVETRYCATCH);
12264
12265 /* The returned optree is actually threaded up slightly nonobviously in
12266 * terms of its ->op_next pointers.
12267 *
12268 * This way, if the tryblock dies, its retop points at the OP_CATCH, but
12269 * if it does not then its leavetry skips over that and continues
12270 * execution past it.
12271 */
12272
12273 /* First, link up the actual body of the catch block */
12274 catchroot = OpSIBLING(cUNOPx(catchkid)->op_first);
12275 catchstart = LINKLIST(catchroot);
12276 cLOGOPx(catchkid)->op_other = catchstart;
12277
12278 o->op_next = LINKLIST(o);
12279
12280 /* die within try block should jump to the catch */
12281 enter->op_other = catchkid;
12282
12283 /* after try block that doesn't die, just skip straight to leavetrycatch */
12284 trykid->op_next = o;
12285
12286 /* after catch block, skip back up to the leavetrycatch */
12287 catchroot->op_next = o;
12288
12289 return o;
12290 }
12291
12292 OP *
Perl_ck_exec(pTHX_ OP * o)12293 Perl_ck_exec(pTHX_ OP *o)
12294 {
12295 PERL_ARGS_ASSERT_CK_EXEC;
12296
12297 if (o->op_flags & OPf_STACKED) {
12298 OP *kid;
12299 o = ck_fun(o);
12300 kid = OpSIBLING(cUNOPo->op_first);
12301 if (kid->op_type == OP_RV2GV)
12302 op_null(kid);
12303 }
12304 else
12305 o = listkids(o);
12306 return o;
12307 }
12308
12309 OP *
Perl_ck_exists(pTHX_ OP * o)12310 Perl_ck_exists(pTHX_ OP *o)
12311 {
12312 PERL_ARGS_ASSERT_CK_EXISTS;
12313
12314 o = ck_fun(o);
12315 if (o->op_flags & OPf_KIDS) {
12316 OP * const kid = cUNOPo->op_first;
12317 if (kid->op_type == OP_ENTERSUB) {
12318 (void) ref(kid, o->op_type);
12319 if (kid->op_type != OP_RV2CV
12320 && !(PL_parser && PL_parser->error_count))
12321 Perl_croak(aTHX_
12322 "exists argument is not a subroutine name");
12323 o->op_private |= OPpEXISTS_SUB;
12324 }
12325 else if (kid->op_type == OP_AELEM)
12326 o->op_flags |= OPf_SPECIAL;
12327 else if (kid->op_type != OP_HELEM)
12328 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12329 "element or a subroutine");
12330 op_null(kid);
12331 }
12332 return o;
12333 }
12334
12335 OP *
Perl_ck_helemexistsor(pTHX_ OP * o)12336 Perl_ck_helemexistsor(pTHX_ OP *o)
12337 {
12338 PERL_ARGS_ASSERT_CK_HELEMEXISTSOR;
12339
12340 o = ck_fun(o);
12341
12342 OP *first;
12343 if(!(o->op_flags & OPf_KIDS) ||
12344 !(first = cLOGOPo->op_first) ||
12345 first->op_type != OP_HELEM)
12346 /* As this opcode isn't currently exposed to pure-perl, only core or XS
12347 * authors are ever going to see this message. We don't need to list it
12348 * in perldiag as to do so would require documenting OP_HELEMEXISTSOR
12349 * itself
12350 */
12351 /* diag_listed_as: SKIPME */
12352 croak("OP_HELEMEXISTSOR argument is not a HASH element");
12353
12354 OP *hvop = cBINOPx(first)->op_first;
12355 OP *keyop = OpSIBLING(hvop);
12356 assert(!OpSIBLING(keyop));
12357
12358 op_null(first); // null out the OP_HELEM
12359
12360 keyop->op_next = o;
12361
12362 return o;
12363 }
12364
12365 OP *
Perl_ck_rvconst(pTHX_ OP * o)12366 Perl_ck_rvconst(pTHX_ OP *o)
12367 {
12368 SVOP * const kid = cSVOPx(cUNOPo->op_first);
12369
12370 PERL_ARGS_ASSERT_CK_RVCONST;
12371
12372 if (o->op_type == OP_RV2HV)
12373 /* rv2hv steals the bottom bit for its own uses */
12374 o->op_private &= ~OPpARG1_MASK;
12375
12376 o->op_private |= (PL_hints & HINT_STRICT_REFS);
12377
12378 if (kid->op_type == OP_CONST) {
12379 int iscv;
12380 GV *gv;
12381 SV * const kidsv = kid->op_sv;
12382
12383 /* Is it a constant from cv_const_sv()? */
12384 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12385 return o;
12386 }
12387 if (SvTYPE(kidsv) == SVt_PVAV) return o;
12388 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12389 const char *badthing;
12390 switch (o->op_type) {
12391 case OP_RV2SV:
12392 badthing = "a SCALAR";
12393 break;
12394 case OP_RV2AV:
12395 badthing = "an ARRAY";
12396 break;
12397 case OP_RV2HV:
12398 badthing = "a HASH";
12399 break;
12400 default:
12401 badthing = NULL;
12402 break;
12403 }
12404 if (badthing)
12405 Perl_croak(aTHX_
12406 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12407 SVfARG(kidsv), badthing);
12408 }
12409 /*
12410 * This is a little tricky. We only want to add the symbol if we
12411 * didn't add it in the lexer. Otherwise we get duplicate strict
12412 * warnings. But if we didn't add it in the lexer, we must at
12413 * least pretend like we wanted to add it even if it existed before,
12414 * or we get possible typo warnings. OPpCONST_ENTERED says
12415 * whether the lexer already added THIS instance of this symbol.
12416 */
12417 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12418 gv = gv_fetchsv(kidsv,
12419 o->op_type == OP_RV2CV
12420 && o->op_private & OPpMAY_RETURN_CONSTANT
12421 ? GV_NOEXPAND
12422 : iscv | !(kid->op_private & OPpCONST_ENTERED),
12423 iscv
12424 ? SVt_PVCV
12425 : o->op_type == OP_RV2SV
12426 ? SVt_PV
12427 : o->op_type == OP_RV2AV
12428 ? SVt_PVAV
12429 : o->op_type == OP_RV2HV
12430 ? SVt_PVHV
12431 : SVt_PVGV);
12432 if (gv) {
12433 if (!isGV(gv)) {
12434 assert(iscv);
12435 assert(SvROK(gv));
12436 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12437 && SvTYPE(SvRV(gv)) != SVt_PVCV)
12438 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12439 }
12440 OpTYPE_set(kid, OP_GV);
12441 SvREFCNT_dec(kid->op_sv);
12442 #ifdef USE_ITHREADS
12443 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12444 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12445 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12446 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12447 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12448 #else
12449 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12450 #endif
12451 kid->op_private = 0;
12452 /* FAKE globs in the symbol table cause weird bugs (#77810) */
12453 SvFAKE_off(gv);
12454 }
12455 }
12456 return o;
12457 }
12458
12459 OP *
Perl_ck_ftst(pTHX_ OP * o)12460 Perl_ck_ftst(pTHX_ OP *o)
12461 {
12462 const I32 type = o->op_type;
12463
12464 PERL_ARGS_ASSERT_CK_FTST;
12465
12466 if (o->op_flags & OPf_REF) {
12467 NOOP;
12468 }
12469 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12470 SVOP * const kid = cSVOPx(cUNOPo->op_first);
12471 const OPCODE kidtype = kid->op_type;
12472
12473 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12474 && !kid->op_folded) {
12475 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12476 no_bareword_filehandle(SvPVX(kSVOP_sv));
12477 }
12478 OP * const newop = newGVOP(type, OPf_REF,
12479 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12480 op_free(o);
12481 return newop;
12482 }
12483
12484 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12485 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12486 if (name) {
12487 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12488 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12489 array_passed_to_stat, name);
12490 }
12491 else {
12492 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12493 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12494 }
12495 }
12496 scalar((OP *) kid);
12497 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12498 o->op_private |= OPpFT_ACCESS;
12499 if (OP_IS_FILETEST(type)
12500 && OP_IS_FILETEST(kidtype)
12501 ) {
12502 o->op_private |= OPpFT_STACKED;
12503 kid->op_private |= OPpFT_STACKING;
12504 if (kidtype == OP_FTTTY && (
12505 !(kid->op_private & OPpFT_STACKED)
12506 || kid->op_private & OPpFT_AFTER_t
12507 ))
12508 o->op_private |= OPpFT_AFTER_t;
12509 }
12510 }
12511 else {
12512 op_free(o);
12513 if (type == OP_FTTTY)
12514 o = newGVOP(type, OPf_REF, PL_stdingv);
12515 else
12516 o = newUNOP(type, 0, newDEFSVOP());
12517 }
12518 return o;
12519 }
12520
12521 OP *
Perl_ck_fun(pTHX_ OP * o)12522 Perl_ck_fun(pTHX_ OP *o)
12523 {
12524 const int type = o->op_type;
12525 I32 oa = PL_opargs[type] >> OASHIFT;
12526
12527 PERL_ARGS_ASSERT_CK_FUN;
12528
12529 if (o->op_flags & OPf_STACKED) {
12530 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12531 oa &= ~OA_OPTIONAL;
12532 else
12533 return no_fh_allowed(o);
12534 }
12535
12536 if (o->op_flags & OPf_KIDS) {
12537 OP *prev_kid = NULL;
12538 OP *kid = cLISTOPo->op_first;
12539 I32 numargs = 0;
12540 bool seen_optional = FALSE;
12541
12542 if (kid->op_type == OP_PUSHMARK ||
12543 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
12544 {
12545 prev_kid = kid;
12546 kid = OpSIBLING(kid);
12547 }
12548 if (kid && kid->op_type == OP_COREARGS) {
12549 bool optional = FALSE;
12550 while (oa) {
12551 numargs++;
12552 if (oa & OA_OPTIONAL) optional = TRUE;
12553 oa = oa >> 4;
12554 }
12555 if (optional) o->op_private |= numargs;
12556 return o;
12557 }
12558
12559 while (oa) {
12560 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
12561 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
12562 kid = newDEFSVOP();
12563 /* append kid to chain */
12564 op_sibling_splice(o, prev_kid, 0, kid);
12565 }
12566 seen_optional = TRUE;
12567 }
12568 if (!kid) break;
12569
12570 numargs++;
12571 switch (oa & 7) {
12572 case OA_SCALAR:
12573 /* list seen where single (scalar) arg expected? */
12574 if (numargs == 1 && !(oa >> 4)
12575 && kid->op_type == OP_LIST && type != OP_SCALAR)
12576 {
12577 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12578 }
12579 if (type != OP_DELETE) scalar(kid);
12580 break;
12581 case OA_LIST:
12582 if (oa < 16) {
12583 kid = 0;
12584 continue;
12585 }
12586 else
12587 list(kid);
12588 break;
12589 case OA_AVREF:
12590 if ((type == OP_PUSH || type == OP_UNSHIFT)
12591 && !OpHAS_SIBLING(kid))
12592 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12593 "Useless use of %s with no values",
12594 PL_op_desc[type]);
12595
12596 if (kid->op_type == OP_CONST
12597 && ( !SvROK(cSVOPx_sv(kid))
12598 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
12599 )
12600 bad_type_pv(numargs, "array", o, kid);
12601 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
12602 || kid->op_type == OP_RV2GV) {
12603 bad_type_pv(1, "array", o, kid);
12604 }
12605 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
12606 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
12607 PL_op_desc[type]), 0);
12608 }
12609 else {
12610 op_lvalue(kid, type);
12611 }
12612 break;
12613 case OA_HVREF:
12614 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
12615 bad_type_pv(numargs, "hash", o, kid);
12616 op_lvalue(kid, type);
12617 break;
12618 case OA_CVREF:
12619 {
12620 /* replace kid with newop in chain */
12621 OP * const newop =
12622 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
12623 newop->op_next = newop;
12624 kid = newop;
12625 }
12626 break;
12627 case OA_FILEREF:
12628 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
12629 if (kid->op_type == OP_CONST &&
12630 (kid->op_private & OPpCONST_BARE))
12631 {
12632 OP * const newop = newGVOP(OP_GV, 0,
12633 gv_fetchsv(kSVOP->op_sv, GV_ADD, SVt_PVIO));
12634 /* a first argument is handled by toke.c, ideally we'd
12635 just check here but several ops don't use ck_fun() */
12636 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12637 no_bareword_filehandle(SvPVX(kSVOP_sv));
12638 }
12639 /* replace kid with newop in chain */
12640 op_sibling_splice(o, prev_kid, 1, newop);
12641 op_free(kid);
12642 kid = newop;
12643 }
12644 else if (kid->op_type == OP_READLINE) {
12645 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
12646 bad_type_pv(numargs, "HANDLE", o, kid);
12647 }
12648 else {
12649 I32 flags = OPf_SPECIAL;
12650 I32 priv = 0;
12651 PADOFFSET targ = 0;
12652
12653 /* is this op a FH constructor? */
12654 if (is_handle_constructor(o,numargs)) {
12655 const char *name = NULL;
12656 STRLEN len = 0;
12657 U32 name_utf8 = 0;
12658 bool want_dollar = TRUE;
12659
12660 flags = 0;
12661 /* Set a flag to tell rv2gv to vivify
12662 * need to "prove" flag does not mean something
12663 * else already - NI-S 1999/05/07
12664 */
12665 priv = OPpDEREF;
12666 if (kid->op_type == OP_PADSV) {
12667 PADNAME * const pn
12668 = PAD_COMPNAME_SV(kid->op_targ);
12669 name = PadnamePV (pn);
12670 len = PadnameLEN(pn);
12671 name_utf8 = PadnameUTF8(pn);
12672 }
12673 else if (kid->op_type == OP_RV2SV
12674 && kUNOP->op_first->op_type == OP_GV)
12675 {
12676 GV * const gv = cGVOPx_gv(kUNOP->op_first);
12677 name = GvNAME(gv);
12678 len = GvNAMELEN(gv);
12679 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
12680 }
12681 else if (kid->op_type == OP_AELEM
12682 || kid->op_type == OP_HELEM)
12683 {
12684 OP *firstop;
12685 OP *op = kBINOP->op_first;
12686 name = NULL;
12687 if (op) {
12688 SV *tmpstr = NULL;
12689 const char * const a =
12690 kid->op_type == OP_AELEM ?
12691 "[]" : "{}";
12692 if (((op->op_type == OP_RV2AV) ||
12693 (op->op_type == OP_RV2HV)) &&
12694 (firstop = cUNOPx(op)->op_first) &&
12695 (firstop->op_type == OP_GV)) {
12696 /* packagevar $a[] or $h{} */
12697 GV * const gv = cGVOPx_gv(firstop);
12698 if (gv)
12699 tmpstr =
12700 Perl_newSVpvf(aTHX_
12701 "%s%c...%c",
12702 GvNAME(gv),
12703 a[0], a[1]);
12704 }
12705 else if (op->op_type == OP_PADAV
12706 || op->op_type == OP_PADHV) {
12707 /* lexicalvar $a[] or $h{} */
12708 const char * const padname =
12709 PAD_COMPNAME_PV(op->op_targ);
12710 if (padname)
12711 tmpstr =
12712 Perl_newSVpvf(aTHX_
12713 "%s%c...%c",
12714 padname + 1,
12715 a[0], a[1]);
12716 }
12717 if (tmpstr) {
12718 name = SvPV_const(tmpstr, len);
12719 name_utf8 = SvUTF8(tmpstr);
12720 sv_2mortal(tmpstr);
12721 }
12722 }
12723 if (!name) {
12724 name = "__ANONIO__";
12725 len = 10;
12726 want_dollar = FALSE;
12727 }
12728 op_lvalue(kid, type);
12729 }
12730 if (name) {
12731 SV *namesv;
12732 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
12733 namesv = PAD_SVl(targ);
12734 if (want_dollar && *name != '$')
12735 sv_setpvs(namesv, "$");
12736 else
12737 SvPVCLEAR(namesv);
12738 sv_catpvn(namesv, name, len);
12739 if ( name_utf8 ) SvUTF8_on(namesv);
12740 }
12741 }
12742 scalar(kid);
12743 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
12744 OP_RV2GV, flags);
12745 kid->op_targ = targ;
12746 kid->op_private |= priv;
12747 }
12748 }
12749 scalar(kid);
12750 break;
12751 case OA_SCALARREF:
12752 if ((type == OP_UNDEF || type == OP_POS)
12753 && numargs == 1 && !(oa >> 4)
12754 && kid->op_type == OP_LIST)
12755 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12756 op_lvalue(scalar(kid), type);
12757 break;
12758 }
12759 oa >>= 4;
12760 prev_kid = kid;
12761 kid = OpSIBLING(kid);
12762 }
12763 /* FIXME - should the numargs or-ing move after the too many
12764 * arguments check? */
12765 o->op_private |= numargs;
12766 if (kid)
12767 return too_many_arguments_pv(o,OP_DESC(o), 0);
12768 listkids(o);
12769 }
12770 else if (PL_opargs[type] & OA_DEFGV) {
12771 /* Ordering of these two is important to keep f_map.t passing. */
12772 op_free(o);
12773 return newUNOP(type, 0, newDEFSVOP());
12774 }
12775
12776 if (oa) {
12777 while (oa & OA_OPTIONAL)
12778 oa >>= 4;
12779 if (oa && oa != OA_LIST)
12780 return too_few_arguments_pv(o,OP_DESC(o), 0);
12781 }
12782 return o;
12783 }
12784
12785 OP *
Perl_ck_glob(pTHX_ OP * o)12786 Perl_ck_glob(pTHX_ OP *o)
12787 {
12788 GV *gv;
12789
12790 PERL_ARGS_ASSERT_CK_GLOB;
12791
12792 o = ck_fun(o);
12793 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
12794 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
12795
12796 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
12797 {
12798 /* convert
12799 * glob
12800 * \ null - const(wildcard)
12801 * into
12802 * null
12803 * \ enter
12804 * \ list
12805 * \ mark - glob - rv2cv
12806 * | \ gv(CORE::GLOBAL::glob)
12807 * |
12808 * \ null - const(wildcard)
12809 */
12810 o->op_flags |= OPf_SPECIAL;
12811 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12812 o = S_new_entersubop(aTHX_ gv, o);
12813 o = newUNOP(OP_NULL, 0, o);
12814 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12815 return o;
12816 }
12817 else o->op_flags &= ~OPf_SPECIAL;
12818 #if !defined(PERL_EXTERNAL_GLOB)
12819 if (!PL_globhook) {
12820 ENTER;
12821 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12822 newSVpvs("File::Glob"), NULL, NULL, NULL);
12823 LEAVE;
12824 }
12825 #endif /* !PERL_EXTERNAL_GLOB */
12826 gv = (GV *)newSV_type(SVt_NULL);
12827 gv_init(gv, 0, "", 0, 0);
12828 gv_IOadd(gv);
12829 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12830 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12831 scalarkids(o);
12832 return o;
12833 }
12834
12835 OP *
Perl_ck_grep(pTHX_ OP * o)12836 Perl_ck_grep(pTHX_ OP *o)
12837 {
12838 LOGOP *gwop;
12839 OP *kid;
12840 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12841
12842 PERL_ARGS_ASSERT_CK_GREP;
12843
12844 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12845
12846 if (o->op_flags & OPf_STACKED) {
12847 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12848 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12849 return no_fh_allowed(o);
12850 o->op_flags &= ~OPf_STACKED;
12851 }
12852 kid = OpSIBLING(cLISTOPo->op_first);
12853 if (type == OP_MAPWHILE)
12854 list(kid);
12855 else
12856 scalar(kid);
12857 o = ck_fun(o);
12858 if (PL_parser && PL_parser->error_count)
12859 return o;
12860 kid = OpSIBLING(cLISTOPo->op_first);
12861 if (kid->op_type != OP_NULL)
12862 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12863 kid = kUNOP->op_first;
12864
12865 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12866 kid->op_next = (OP*)gwop;
12867 o->op_private = gwop->op_private = 0;
12868 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12869
12870 kid = OpSIBLING(cLISTOPo->op_first);
12871 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12872 op_lvalue(kid, OP_GREPSTART);
12873
12874 return (OP*)gwop;
12875 }
12876
12877 OP *
Perl_ck_index(pTHX_ OP * o)12878 Perl_ck_index(pTHX_ OP *o)
12879 {
12880 PERL_ARGS_ASSERT_CK_INDEX;
12881
12882 if (o->op_flags & OPf_KIDS) {
12883 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12884 if (kid)
12885 kid = OpSIBLING(kid); /* get past "big" */
12886 if (kid && kid->op_type == OP_CONST) {
12887 const bool save_taint = TAINT_get;
12888 SV *sv = kSVOP->op_sv;
12889 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12890 && SvOK(sv) && !SvROK(sv))
12891 {
12892 sv = newSV_type(SVt_NULL);
12893 sv_copypv(sv, kSVOP->op_sv);
12894 SvREFCNT_dec_NN(kSVOP->op_sv);
12895 kSVOP->op_sv = sv;
12896 }
12897 if (SvOK(sv)) fbm_compile(sv, 0);
12898 TAINT_set(save_taint);
12899 #ifdef NO_TAINT_SUPPORT
12900 PERL_UNUSED_VAR(save_taint);
12901 #endif
12902 }
12903 }
12904 return ck_fun(o);
12905 }
12906
12907 OP *
Perl_ck_lfun(pTHX_ OP * o)12908 Perl_ck_lfun(pTHX_ OP *o)
12909 {
12910 const OPCODE type = o->op_type;
12911
12912 PERL_ARGS_ASSERT_CK_LFUN;
12913
12914 return modkids(ck_fun(o), type);
12915 }
12916
12917 OP *
Perl_ck_defined(pTHX_ OP * o)12918 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
12919 {
12920 PERL_ARGS_ASSERT_CK_DEFINED;
12921
12922 if ((o->op_flags & OPf_KIDS)) {
12923 switch (cUNOPo->op_first->op_type) {
12924 case OP_RV2AV:
12925 case OP_PADAV:
12926 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12927 " (Maybe you should just omit the defined()?)");
12928 NOT_REACHED; /* NOTREACHED */
12929 break;
12930 case OP_RV2HV:
12931 case OP_PADHV:
12932 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12933 " (Maybe you should just omit the defined()?)");
12934 NOT_REACHED; /* NOTREACHED */
12935 break;
12936 default:
12937 /* no warning */
12938 break;
12939 }
12940 }
12941 return ck_rfun(o);
12942 }
12943
12944 OP *
Perl_ck_readline(pTHX_ OP * o)12945 Perl_ck_readline(pTHX_ OP *o)
12946 {
12947 PERL_ARGS_ASSERT_CK_READLINE;
12948
12949 if (o->op_flags & OPf_KIDS) {
12950 OP *kid = cLISTOPo->op_first;
12951 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED
12952 && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
12953 no_bareword_filehandle(SvPVX(kSVOP_sv));
12954 }
12955 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12956 scalar(kid);
12957 }
12958 else {
12959 OP * const newop
12960 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12961 op_free(o);
12962 return newop;
12963 }
12964 return o;
12965 }
12966
12967 OP *
Perl_ck_rfun(pTHX_ OP * o)12968 Perl_ck_rfun(pTHX_ OP *o)
12969 {
12970 const OPCODE type = o->op_type;
12971
12972 PERL_ARGS_ASSERT_CK_RFUN;
12973
12974 return refkids(ck_fun(o), type);
12975 }
12976
12977 OP *
Perl_ck_listiob(pTHX_ OP * o)12978 Perl_ck_listiob(pTHX_ OP *o)
12979 {
12980 OP *kid;
12981
12982 PERL_ARGS_ASSERT_CK_LISTIOB;
12983
12984 kid = cLISTOPo->op_first;
12985 if (!kid) {
12986 o = op_force_list(o);
12987 kid = cLISTOPo->op_first;
12988 }
12989 if (kid->op_type == OP_PUSHMARK)
12990 kid = OpSIBLING(kid);
12991 if (kid && o->op_flags & OPf_STACKED)
12992 kid = OpSIBLING(kid);
12993 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
12994 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12995 && !kid->op_folded) {
12996 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12997 no_bareword_filehandle(SvPVX(kSVOP_sv));
12998 }
12999 o->op_flags |= OPf_STACKED; /* make it a filehandle */
13000 scalar(kid);
13001 /* replace old const op with new OP_RV2GV parent */
13002 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13003 OP_RV2GV, OPf_REF);
13004 kid = OpSIBLING(kid);
13005 }
13006 }
13007
13008 if (!kid)
13009 op_append_elem(o->op_type, o, newDEFSVOP());
13010
13011 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13012 return listkids(o);
13013 }
13014
13015 OP *
Perl_ck_smartmatch(pTHX_ OP * o)13016 Perl_ck_smartmatch(pTHX_ OP *o)
13017 {
13018 PERL_ARGS_ASSERT_CK_SMARTMATCH;
13019 if (0 == (o->op_flags & OPf_SPECIAL)) {
13020 OP *first = cBINOPo->op_first;
13021 OP *second = OpSIBLING(first);
13022
13023 /* Implicitly take a reference to an array or hash */
13024
13025 /* remove the original two siblings, then add back the
13026 * (possibly different) first and second sibs.
13027 */
13028 op_sibling_splice(o, NULL, 1, NULL);
13029 op_sibling_splice(o, NULL, 1, NULL);
13030 first = ref_array_or_hash(first);
13031 second = ref_array_or_hash(second);
13032 op_sibling_splice(o, NULL, 0, second);
13033 op_sibling_splice(o, NULL, 0, first);
13034
13035 /* Implicitly take a reference to a regular expression */
13036 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13037 OpTYPE_set(first, OP_QR);
13038 }
13039 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13040 OpTYPE_set(second, OP_QR);
13041 }
13042 }
13043
13044 return o;
13045 }
13046
13047
13048 static OP *
S_maybe_targlex(pTHX_ OP * o)13049 S_maybe_targlex(pTHX_ OP *o)
13050 {
13051 OP * const kid = cLISTOPo->op_first;
13052 /* has a disposable target? */
13053 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13054 && !(kid->op_flags & OPf_STACKED)
13055 /* Cannot steal the second time! */
13056 && !(kid->op_private & OPpTARGET_MY)
13057 )
13058 {
13059 OP * const kkid = OpSIBLING(kid);
13060
13061 /* Can just relocate the target. */
13062 if (kkid && kkid->op_type == OP_PADSV
13063 && (!(kkid->op_private & OPpLVAL_INTRO)
13064 || kkid->op_private & OPpPAD_STATE))
13065 {
13066 kid->op_targ = kkid->op_targ;
13067 kkid->op_targ = 0;
13068 /* Now we do not need PADSV and SASSIGN.
13069 * Detach kid and free the rest. */
13070 op_sibling_splice(o, NULL, 1, NULL);
13071 op_free(o);
13072 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
13073 return kid;
13074 }
13075 }
13076 return o;
13077 }
13078
13079 OP *
Perl_ck_sassign(pTHX_ OP * o)13080 Perl_ck_sassign(pTHX_ OP *o)
13081 {
13082 OP * const kid = cBINOPo->op_first;
13083
13084 PERL_ARGS_ASSERT_CK_SASSIGN;
13085
13086 if (OpHAS_SIBLING(kid)) {
13087 OP *kkid = OpSIBLING(kid);
13088 /* For state variable assignment with attributes, kkid is a list op
13089 whose op_last is a padsv. */
13090 if ((kkid->op_type == OP_PADSV ||
13091 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13092 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13093 )
13094 )
13095 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13096 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13097 return S_newONCEOP(aTHX_ o, kkid);
13098 }
13099 }
13100 return S_maybe_targlex(aTHX_ o);
13101 }
13102
13103
13104 OP *
Perl_ck_match(pTHX_ OP * o)13105 Perl_ck_match(pTHX_ OP *o)
13106 {
13107 PERL_UNUSED_CONTEXT;
13108 PERL_ARGS_ASSERT_CK_MATCH;
13109
13110 return o;
13111 }
13112
13113 OP *
Perl_ck_method(pTHX_ OP * o)13114 Perl_ck_method(pTHX_ OP *o)
13115 {
13116 SV *sv, *methsv, *rclass;
13117 const char* method;
13118 char* compatptr;
13119 int utf8;
13120 STRLEN len, nsplit = 0, i;
13121 OP* new_op;
13122 OP * const kid = cUNOPo->op_first;
13123
13124 PERL_ARGS_ASSERT_CK_METHOD;
13125 if (kid->op_type != OP_CONST) return o;
13126
13127 sv = kSVOP->op_sv;
13128
13129 /* replace ' with :: */
13130 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13131 SvEND(sv) - SvPVX(sv) )))
13132 {
13133 *compatptr = ':';
13134 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13135 }
13136
13137 method = SvPVX_const(sv);
13138 len = SvCUR(sv);
13139 utf8 = SvUTF8(sv) ? -1 : 1;
13140
13141 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13142 nsplit = i+1;
13143 break;
13144 }
13145
13146 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13147
13148 if (!nsplit) { /* $proto->method() */
13149 op_free(o);
13150 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13151 }
13152
13153 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13154 op_free(o);
13155 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13156 }
13157
13158 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13159 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13160 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13161 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13162 } else {
13163 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13164 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13165 }
13166 #ifdef USE_ITHREADS
13167 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13168 #else
13169 cMETHOPx(new_op)->op_rclass_sv = rclass;
13170 #endif
13171 op_free(o);
13172 return new_op;
13173 }
13174
13175 OP *
Perl_ck_null(pTHX_ OP * o)13176 Perl_ck_null(pTHX_ OP *o)
13177 {
13178 PERL_ARGS_ASSERT_CK_NULL;
13179 PERL_UNUSED_CONTEXT;
13180 return o;
13181 }
13182
13183 OP *
Perl_ck_open(pTHX_ OP * o)13184 Perl_ck_open(pTHX_ OP *o)
13185 {
13186 PERL_ARGS_ASSERT_CK_OPEN;
13187
13188 S_io_hints(aTHX_ o);
13189 {
13190 /* In case of three-arg dup open remove strictness
13191 * from the last arg if it is a bareword. */
13192 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13193 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
13194 OP *oa;
13195 const char *mode;
13196
13197 if ((last->op_type == OP_CONST) && /* The bareword. */
13198 (last->op_private & OPpCONST_BARE) &&
13199 (last->op_private & OPpCONST_STRICT) &&
13200 (oa = OpSIBLING(first)) && /* The fh. */
13201 (oa = OpSIBLING(oa)) && /* The mode. */
13202 (oa->op_type == OP_CONST) &&
13203 SvPOK(cSVOPx(oa)->op_sv) &&
13204 (mode = SvPVX_const(cSVOPx(oa)->op_sv)) &&
13205 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
13206 (last == OpSIBLING(oa))) /* The bareword. */
13207 last->op_private &= ~OPpCONST_STRICT;
13208 }
13209 return ck_fun(o);
13210 }
13211
13212 OP *
Perl_ck_prototype(pTHX_ OP * o)13213 Perl_ck_prototype(pTHX_ OP *o)
13214 {
13215 PERL_ARGS_ASSERT_CK_PROTOTYPE;
13216 if (!(o->op_flags & OPf_KIDS)) {
13217 op_free(o);
13218 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13219 }
13220 return o;
13221 }
13222
13223 OP *
Perl_ck_refassign(pTHX_ OP * o)13224 Perl_ck_refassign(pTHX_ OP *o)
13225 {
13226 OP * const right = cLISTOPo->op_first;
13227 OP * const left = OpSIBLING(right);
13228 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13229 bool stacked = 0;
13230
13231 PERL_ARGS_ASSERT_CK_REFASSIGN;
13232 assert (left);
13233 assert (left->op_type == OP_SREFGEN);
13234
13235 o->op_private = 0;
13236 /* we use OPpPAD_STATE in refassign to mean either of those things,
13237 * and the code assumes the two flags occupy the same bit position
13238 * in the various ops below */
13239 assert(OPpPAD_STATE == OPpOUR_INTRO);
13240
13241 switch (varop->op_type) {
13242 case OP_PADAV:
13243 o->op_private |= OPpLVREF_AV;
13244 goto settarg;
13245 case OP_PADHV:
13246 o->op_private |= OPpLVREF_HV;
13247 /* FALLTHROUGH */
13248 case OP_PADSV:
13249 settarg:
13250 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13251 o->op_targ = varop->op_targ;
13252 varop->op_targ = 0;
13253 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13254 break;
13255
13256 case OP_RV2AV:
13257 o->op_private |= OPpLVREF_AV;
13258 goto checkgv;
13259 NOT_REACHED; /* NOTREACHED */
13260 case OP_RV2HV:
13261 o->op_private |= OPpLVREF_HV;
13262 /* FALLTHROUGH */
13263 case OP_RV2SV:
13264 checkgv:
13265 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13266 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13267 detach_and_stack:
13268 /* Point varop to its GV kid, detached. */
13269 varop = op_sibling_splice(varop, NULL, -1, NULL);
13270 stacked = TRUE;
13271 break;
13272 case OP_RV2CV: {
13273 OP * const kidparent =
13274 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13275 OP * const kid = cUNOPx(kidparent)->op_first;
13276 o->op_private |= OPpLVREF_CV;
13277 if (kid->op_type == OP_GV) {
13278 SV *sv = (SV*)cGVOPx_gv(kid);
13279 varop = kidparent;
13280 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13281 /* a CVREF here confuses pp_refassign, so make sure
13282 it gets a GV */
13283 CV *const cv = (CV*)SvRV(sv);
13284 SV *name_sv = newSVhek_mortal(CvNAME_HEK(cv));
13285 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13286 assert(SvTYPE(sv) == SVt_PVGV);
13287 }
13288 goto detach_and_stack;
13289 }
13290 if (kid->op_type != OP_PADCV) goto bad;
13291 o->op_targ = kid->op_targ;
13292 kid->op_targ = 0;
13293 break;
13294 }
13295 case OP_AELEM:
13296 case OP_HELEM:
13297 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13298 o->op_private |= OPpLVREF_ELEM;
13299 op_null(varop);
13300 stacked = TRUE;
13301 /* Detach varop. */
13302 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13303 break;
13304 default:
13305 bad:
13306 /* diag_listed_as: Can't modify reference to %s in %s assignment */
13307 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13308 "assignment",
13309 OP_DESC(varop)));
13310 return o;
13311 }
13312 if (!FEATURE_REFALIASING_IS_ENABLED)
13313 Perl_croak(aTHX_
13314 "Experimental aliasing via reference not enabled");
13315 Perl_ck_warner_d(aTHX_
13316 packWARN(WARN_EXPERIMENTAL__REFALIASING),
13317 "Aliasing via reference is experimental");
13318 if (stacked) {
13319 o->op_flags |= OPf_STACKED;
13320 op_sibling_splice(o, right, 1, varop);
13321 }
13322 else {
13323 o->op_flags &=~ OPf_STACKED;
13324 op_sibling_splice(o, right, 1, NULL);
13325 }
13326 op_free(left);
13327 return o;
13328 }
13329
13330 OP *
Perl_ck_repeat(pTHX_ OP * o)13331 Perl_ck_repeat(pTHX_ OP *o)
13332 {
13333 PERL_ARGS_ASSERT_CK_REPEAT;
13334
13335 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13336 OP* kids;
13337 o->op_private |= OPpREPEAT_DOLIST;
13338 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13339 kids = op_force_list(kids); /* promote it to a list */
13340 op_sibling_splice(o, NULL, 0, kids); /* and add back */
13341 }
13342 else
13343 scalar(o);
13344 return o;
13345 }
13346
13347 OP *
Perl_ck_require(pTHX_ OP * o)13348 Perl_ck_require(pTHX_ OP *o)
13349 {
13350 GV* gv;
13351
13352 PERL_ARGS_ASSERT_CK_REQUIRE;
13353
13354 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
13355 SVOP * const kid = cSVOPx(cUNOPo->op_first);
13356 U32 hash;
13357 char *s;
13358 STRLEN len;
13359 if (kid->op_type == OP_CONST) {
13360 SV * const sv = kid->op_sv;
13361 U32 const was_readonly = SvREADONLY(sv);
13362 if (kid->op_private & OPpCONST_BARE) {
13363 const char *end;
13364 HEK *hek;
13365
13366 if (was_readonly) {
13367 SvREADONLY_off(sv);
13368 }
13369
13370 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13371
13372 s = SvPVX(sv);
13373 len = SvCUR(sv);
13374 end = s + len;
13375 /* treat ::foo::bar as foo::bar */
13376 if (len >= 2 && s[0] == ':' && s[1] == ':')
13377 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13378 if (s == end)
13379 DIE(aTHX_ "Bareword in require maps to empty filename");
13380
13381 for (; s < end; s++) {
13382 if (*s == ':' && s[1] == ':') {
13383 *s = '/';
13384 Move(s+2, s+1, end - s - 1, char);
13385 --end;
13386 }
13387 }
13388 SvEND_set(sv, end);
13389 sv_catpvs(sv, ".pm");
13390 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13391 hek = share_hek(SvPVX(sv),
13392 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13393 hash);
13394 sv_sethek(sv, hek);
13395 unshare_hek(hek);
13396 SvFLAGS(sv) |= was_readonly;
13397 }
13398 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13399 && !SvVOK(sv)) {
13400 s = SvPV(sv, len);
13401 if (SvREFCNT(sv) > 1) {
13402 kid->op_sv = newSVpvn_share(
13403 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13404 SvREFCNT_dec_NN(sv);
13405 }
13406 else {
13407 HEK *hek;
13408 if (was_readonly) SvREADONLY_off(sv);
13409 PERL_HASH(hash, s, len);
13410 hek = share_hek(s,
13411 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13412 hash);
13413 sv_sethek(sv, hek);
13414 unshare_hek(hek);
13415 SvFLAGS(sv) |= was_readonly;
13416 }
13417 }
13418 }
13419 }
13420
13421 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13422 /* handle override, if any */
13423 && (gv = gv_override("require", 7))) {
13424 OP *kid, *newop;
13425 if (o->op_flags & OPf_KIDS) {
13426 kid = cUNOPo->op_first;
13427 op_sibling_splice(o, NULL, -1, NULL);
13428 }
13429 else {
13430 kid = newDEFSVOP();
13431 }
13432 op_free(o);
13433 newop = S_new_entersubop(aTHX_ gv, kid);
13434 return newop;
13435 }
13436
13437 return ck_fun(o);
13438 }
13439
13440 OP *
Perl_ck_return(pTHX_ OP * o)13441 Perl_ck_return(pTHX_ OP *o)
13442 {
13443 OP *kid;
13444
13445 PERL_ARGS_ASSERT_CK_RETURN;
13446
13447 kid = OpSIBLING(cLISTOPo->op_first);
13448 if (PL_compcv && CvLVALUE(PL_compcv)) {
13449 for (; kid; kid = OpSIBLING(kid))
13450 op_lvalue(kid, OP_LEAVESUBLV);
13451 }
13452
13453 return o;
13454 }
13455
13456 OP *
Perl_ck_select(pTHX_ OP * o)13457 Perl_ck_select(pTHX_ OP *o)
13458 {
13459 OP* kid;
13460
13461 PERL_ARGS_ASSERT_CK_SELECT;
13462
13463 if (o->op_flags & OPf_KIDS) {
13464 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13465 if (kid && OpHAS_SIBLING(kid)) {
13466 OpTYPE_set(o, OP_SSELECT);
13467 o = ck_fun(o);
13468 return fold_constants(op_integerize(op_std_init(o)));
13469 }
13470 }
13471 o = ck_fun(o);
13472 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13473 if (kid && kid->op_type == OP_RV2GV)
13474 kid->op_private &= ~HINT_STRICT_REFS;
13475 return o;
13476 }
13477
13478 OP *
Perl_ck_shift(pTHX_ OP * o)13479 Perl_ck_shift(pTHX_ OP *o)
13480 {
13481 const I32 type = o->op_type;
13482
13483 PERL_ARGS_ASSERT_CK_SHIFT;
13484
13485 if (!(o->op_flags & OPf_KIDS)) {
13486 OP *argop;
13487
13488 if (!CvUNIQUE(PL_compcv)) {
13489 o->op_flags |= OPf_SPECIAL;
13490 return o;
13491 }
13492
13493 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13494 op_free(o);
13495 return newUNOP(type, 0, scalar(argop));
13496 }
13497 return scalar(ck_fun(o));
13498 }
13499
13500 OP *
Perl_ck_sort(pTHX_ OP * o)13501 Perl_ck_sort(pTHX_ OP *o)
13502 {
13503 OP *firstkid;
13504 OP *kid;
13505 U8 stacked;
13506
13507 PERL_ARGS_ASSERT_CK_SORT;
13508
13509 if (o->op_flags & OPf_STACKED)
13510 simplify_sort(o);
13511 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13512
13513 if (!firstkid)
13514 return too_few_arguments_pv(o,OP_DESC(o), 0);
13515
13516 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
13517 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
13518
13519 /* if the first arg is a code block, process it and mark sort as
13520 * OPf_SPECIAL */
13521 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13522 LINKLIST(kid);
13523 if (kid->op_type == OP_LEAVE)
13524 op_null(kid); /* wipe out leave */
13525 /* Prevent execution from escaping out of the sort block. */
13526 kid->op_next = 0;
13527
13528 /* provide scalar context for comparison function/block */
13529 kid = scalar(firstkid);
13530 kid->op_next = kid;
13531 o->op_flags |= OPf_SPECIAL;
13532 }
13533 else if (kid->op_type == OP_CONST
13534 && kid->op_private & OPpCONST_BARE) {
13535 char tmpbuf[256];
13536 STRLEN len;
13537 PADOFFSET off;
13538 const char * const name = SvPV(kSVOP_sv, len);
13539 *tmpbuf = '&';
13540 assert (len < 256);
13541 Copy(name, tmpbuf+1, len, char);
13542 off = pad_findmy_pvn(tmpbuf, len+1, 0);
13543 if (off != NOT_IN_PAD) {
13544 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
13545 SV * const fq =
13546 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
13547 sv_catpvs(fq, "::");
13548 sv_catsv(fq, kSVOP_sv);
13549 SvREFCNT_dec_NN(kSVOP_sv);
13550 kSVOP->op_sv = fq;
13551 }
13552 else {
13553 /* replace the const op with the pad op */
13554 op_sibling_splice(firstkid, NULL, 1,
13555 newPADxVOP(OP_PADCV, 0, off));
13556 op_free(kid);
13557 }
13558 }
13559 }
13560
13561 firstkid = OpSIBLING(firstkid);
13562 }
13563
13564 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13565 /* provide list context for arguments */
13566 list(kid);
13567 if (stacked)
13568 op_lvalue(kid, OP_GREPSTART);
13569 }
13570
13571 return o;
13572 }
13573
13574 /* for sort { X } ..., where X is one of
13575 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
13576 * elide the second child of the sort (the one containing X),
13577 * and set these flags as appropriate
13578 OPpSORT_NUMERIC;
13579 OPpSORT_INTEGER;
13580 OPpSORT_DESCEND;
13581 * Also, check and warn on lexical $a, $b.
13582 */
13583
13584 STATIC void
S_simplify_sort(pTHX_ OP * o)13585 S_simplify_sort(pTHX_ OP *o)
13586 {
13587 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13588 OP *k;
13589 int descending;
13590 GV *gv;
13591 const char *gvname;
13592 bool have_scopeop;
13593
13594 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
13595
13596 kid = kUNOP->op_first; /* get past null */
13597 if (!(have_scopeop = kid->op_type == OP_SCOPE)
13598 && kid->op_type != OP_LEAVE)
13599 return;
13600 kid = kLISTOP->op_last; /* get past scope */
13601 switch(kid->op_type) {
13602 case OP_NCMP:
13603 case OP_I_NCMP:
13604 case OP_SCMP:
13605 if (!have_scopeop) goto padkids;
13606 break;
13607 default:
13608 return;
13609 }
13610 k = kid; /* remember this node*/
13611 if (kBINOP->op_first->op_type != OP_RV2SV
13612 || kBINOP->op_last ->op_type != OP_RV2SV)
13613 {
13614 /*
13615 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
13616 then used in a comparison. This catches most, but not
13617 all cases. For instance, it catches
13618 sort { my($a); $a <=> $b }
13619 but not
13620 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
13621 (although why you'd do that is anyone's guess).
13622 */
13623
13624 padkids:
13625 if (!ckWARN(WARN_SYNTAX)) return;
13626 kid = kBINOP->op_first;
13627 do {
13628 if (kid->op_type == OP_PADSV) {
13629 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
13630 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
13631 && ( PadnamePV(name)[1] == 'a'
13632 || PadnamePV(name)[1] == 'b' ))
13633 /* diag_listed_as: "my %s" used in sort comparison */
13634 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13635 "\"%s %s\" used in sort comparison",
13636 PadnameIsSTATE(name)
13637 ? "state"
13638 : "my",
13639 PadnamePV(name));
13640 }
13641 } while ((kid = OpSIBLING(kid)));
13642 return;
13643 }
13644 kid = kBINOP->op_first; /* get past cmp */
13645 if (kUNOP->op_first->op_type != OP_GV)
13646 return;
13647 kid = kUNOP->op_first; /* get past rv2sv */
13648 gv = kGVOP_gv;
13649 if (GvSTASH(gv) != PL_curstash)
13650 return;
13651 gvname = GvNAME(gv);
13652 if (*gvname == 'a' && gvname[1] == '\0')
13653 descending = 0;
13654 else if (*gvname == 'b' && gvname[1] == '\0')
13655 descending = 1;
13656 else
13657 return;
13658
13659 kid = k; /* back to cmp */
13660 /* already checked above that it is rv2sv */
13661 kid = kBINOP->op_last; /* down to 2nd arg */
13662 if (kUNOP->op_first->op_type != OP_GV)
13663 return;
13664 kid = kUNOP->op_first; /* get past rv2sv */
13665 gv = kGVOP_gv;
13666 if (GvSTASH(gv) != PL_curstash)
13667 return;
13668 gvname = GvNAME(gv);
13669 if ( descending
13670 ? !(*gvname == 'a' && gvname[1] == '\0')
13671 : !(*gvname == 'b' && gvname[1] == '\0'))
13672 return;
13673 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
13674 if (descending)
13675 o->op_private |= OPpSORT_DESCEND;
13676 if (k->op_type == OP_NCMP)
13677 o->op_private |= OPpSORT_NUMERIC;
13678 if (k->op_type == OP_I_NCMP)
13679 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
13680 kid = OpSIBLING(cLISTOPo->op_first);
13681 /* cut out and delete old block (second sibling) */
13682 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
13683 op_free(kid);
13684 }
13685
13686 OP *
Perl_ck_split(pTHX_ OP * o)13687 Perl_ck_split(pTHX_ OP *o)
13688 {
13689 OP *kid;
13690 OP *sibs;
13691
13692 PERL_ARGS_ASSERT_CK_SPLIT;
13693
13694 assert(o->op_type == OP_LIST);
13695
13696 if (o->op_flags & OPf_STACKED)
13697 return no_fh_allowed(o);
13698
13699 kid = cLISTOPo->op_first;
13700 /* delete leading NULL node, then add a CONST if no other nodes */
13701 assert(kid->op_type == OP_NULL);
13702 op_sibling_splice(o, NULL, 1,
13703 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
13704 op_free(kid);
13705 kid = cLISTOPo->op_first;
13706
13707 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
13708 /* remove match expression, and replace with new optree with
13709 * a match op at its head */
13710 op_sibling_splice(o, NULL, 1, NULL);
13711 /* pmruntime will handle split " " behavior with flag==2 */
13712 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
13713 op_sibling_splice(o, NULL, 0, kid);
13714 }
13715
13716 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
13717
13718 if (kPMOP->op_pmflags & PMf_GLOBAL) {
13719 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
13720 "Use of /g modifier is meaningless in split");
13721 }
13722
13723 /* eliminate the split op, and move the match op (plus any children)
13724 * into its place, then convert the match op into a split op. i.e.
13725 *
13726 * SPLIT MATCH SPLIT(ex-MATCH)
13727 * | | |
13728 * MATCH - A - B - C => R - A - B - C => R - A - B - C
13729 * | | |
13730 * R X - Y X - Y
13731 * |
13732 * X - Y
13733 *
13734 * (R, if it exists, will be a regcomp op)
13735 */
13736
13737 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
13738 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
13739 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
13740 OpTYPE_set(kid, OP_SPLIT);
13741 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
13742 kid->op_private = o->op_private;
13743 op_free(o);
13744 o = kid;
13745 kid = sibs; /* kid is now the string arg of the split */
13746
13747 if (!kid) {
13748 kid = newDEFSVOP();
13749 op_append_elem(OP_SPLIT, o, kid);
13750 }
13751 scalar(kid);
13752
13753 kid = OpSIBLING(kid);
13754 if (!kid) {
13755 kid = newSVOP(OP_CONST, 0, newSViv(0));
13756 op_append_elem(OP_SPLIT, o, kid);
13757 o->op_private |= OPpSPLIT_IMPLIM;
13758 }
13759 scalar(kid);
13760
13761 if (OpHAS_SIBLING(kid))
13762 return too_many_arguments_pv(o,OP_DESC(o), 0);
13763
13764 return o;
13765 }
13766
13767 OP *
Perl_ck_stringify(pTHX_ OP * o)13768 Perl_ck_stringify(pTHX_ OP *o)
13769 {
13770 OP * const kid = OpSIBLING(cUNOPo->op_first);
13771 PERL_ARGS_ASSERT_CK_STRINGIFY;
13772 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
13773 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
13774 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
13775 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
13776 {
13777 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
13778 op_free(o);
13779 return kid;
13780 }
13781 return ck_fun(o);
13782 }
13783
13784 OP *
Perl_ck_join(pTHX_ OP * o)13785 Perl_ck_join(pTHX_ OP *o)
13786 {
13787 OP * const kid = OpSIBLING(cLISTOPo->op_first);
13788
13789 PERL_ARGS_ASSERT_CK_JOIN;
13790
13791 if (kid && kid->op_type == OP_MATCH) {
13792 if (ckWARN(WARN_SYNTAX)) {
13793 const REGEXP *re = PM_GETRE(kPMOP);
13794 const SV *msg = re
13795 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
13796 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
13797 : newSVpvs_flags( "STRING", SVs_TEMP );
13798 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13799 "/%" SVf "/ should probably be written as \"%" SVf "\"",
13800 SVfARG(msg), SVfARG(msg));
13801 }
13802 }
13803 if (kid
13804 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
13805 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
13806 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
13807 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
13808 {
13809 const OP * const bairn = OpSIBLING(kid); /* the list */
13810 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
13811 && OP_GIMME(bairn,0) == G_SCALAR)
13812 {
13813 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13814 op_sibling_splice(o, kid, 1, NULL));
13815 op_free(o);
13816 return ret;
13817 }
13818 }
13819
13820 return ck_fun(o);
13821 }
13822
13823 /*
13824 =for apidoc rv2cv_op_cv
13825
13826 Examines an op, which is expected to identify a subroutine at runtime,
13827 and attempts to determine at compile time which subroutine it identifies.
13828 This is normally used during Perl compilation to determine whether
13829 a prototype can be applied to a function call. C<cvop> is the op
13830 being considered, normally an C<rv2cv> op. A pointer to the identified
13831 subroutine is returned, if it could be determined statically, and a null
13832 pointer is returned if it was not possible to determine statically.
13833
13834 Currently, the subroutine can be identified statically if the RV that the
13835 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13836 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
13837 suitable if the constant value must be an RV pointing to a CV. Details of
13838 this process may change in future versions of Perl. If the C<rv2cv> op
13839 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13840 the subroutine statically: this flag is used to suppress compile-time
13841 magic on a subroutine call, forcing it to use default runtime behaviour.
13842
13843 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13844 of a GV reference is modified. If a GV was examined and its CV slot was
13845 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13846 If the op is not optimised away, and the CV slot is later populated with
13847 a subroutine having a prototype, that flag eventually triggers the warning
13848 "called too early to check prototype".
13849
13850 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13851 of returning a pointer to the subroutine it returns a pointer to the
13852 GV giving the most appropriate name for the subroutine in this context.
13853 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13854 (C<CvANON>) subroutine that is referenced through a GV it will be the
13855 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
13856 A null pointer is returned as usual if there is no statically-determinable
13857 subroutine.
13858
13859 =for apidoc Amnh||OPpEARLY_CV
13860 =for apidoc Amnh||OPpENTERSUB_AMPER
13861 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
13862 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
13863
13864 =cut
13865 */
13866
13867 /* shared by toke.c:yylex */
13868 CV *
Perl_find_lexical_cv(pTHX_ PADOFFSET off)13869 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13870 {
13871 const PADNAME *name = PAD_COMPNAME(off);
13872 CV *compcv = PL_compcv;
13873 while (PadnameOUTER(name)) {
13874 compcv = CvOUTSIDE(compcv);
13875 if (LIKELY(PARENT_PAD_INDEX(name))) {
13876 name = PadlistNAMESARRAY(CvPADLIST(compcv))
13877 [off = PARENT_PAD_INDEX(name)];
13878 }
13879 else {
13880 /* In an eval() in an inner scope like a function, the
13881 intermediate pad in the sub might not be populated with the
13882 sub. So search harder.
13883
13884 It is possible we won't find the name in this
13885 particular scope, but that's fine, if we don't we'll
13886 find it in some outer scope. Finding it here will let us
13887 go back to following the PARENT_PAD_INDEX() chain.
13888 */
13889 const PADNAMELIST * const names = PadlistNAMES(CvPADLIST(compcv));
13890 PADNAME * const * const name_p = PadnamelistARRAY(names);
13891 int offset;
13892 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
13893 const PADNAME * const thisname = name_p[offset];
13894 /* The pv is copied from the outer PADNAME to the
13895 inner PADNAMEs so we don't need to compare the
13896 string contents
13897 */
13898 if (thisname && PadnameLEN(thisname) == PadnameLEN(name)
13899 && PadnamePV(thisname) == PadnamePV(name)) {
13900 name = thisname;
13901 break;
13902 }
13903 }
13904 }
13905 }
13906 assert(!PadnameIsOUR(name));
13907 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13908 return PadnamePROTOCV(name);
13909 }
13910 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13911 }
13912
13913 CV *
Perl_rv2cv_op_cv(pTHX_ OP * cvop,U32 flags)13914 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13915 {
13916 OP *rvop;
13917 CV *cv;
13918 GV *gv;
13919 PERL_ARGS_ASSERT_RV2CV_OP_CV;
13920 if (flags & ~RV2CVOPCV_FLAG_MASK)
13921 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13922 if (cvop->op_type != OP_RV2CV)
13923 return NULL;
13924 if (cvop->op_private & OPpENTERSUB_AMPER)
13925 return NULL;
13926 if (!(cvop->op_flags & OPf_KIDS))
13927 return NULL;
13928 rvop = cUNOPx(cvop)->op_first;
13929 switch (rvop->op_type) {
13930 case OP_GV: {
13931 gv = cGVOPx_gv(rvop);
13932 if (!isGV(gv)) {
13933 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13934 cv = MUTABLE_CV(SvRV(gv));
13935 gv = NULL;
13936 break;
13937 }
13938 if (flags & RV2CVOPCV_RETURN_STUB)
13939 return (CV *)gv;
13940 else return NULL;
13941 }
13942 cv = GvCVu(gv);
13943 if (!cv) {
13944 if (flags & RV2CVOPCV_MARK_EARLY)
13945 rvop->op_private |= OPpEARLY_CV;
13946 return NULL;
13947 }
13948 } break;
13949 case OP_CONST: {
13950 SV *rv = cSVOPx_sv(rvop);
13951 if (!SvROK(rv))
13952 return NULL;
13953 cv = (CV*)SvRV(rv);
13954 gv = NULL;
13955 } break;
13956 case OP_PADCV: {
13957 cv = find_lexical_cv(rvop->op_targ);
13958 gv = NULL;
13959 } break;
13960 default: {
13961 return NULL;
13962 } NOT_REACHED; /* NOTREACHED */
13963 }
13964 if (SvTYPE((SV*)cv) != SVt_PVCV)
13965 return NULL;
13966 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13967 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13968 gv = CvGV(cv);
13969 return (CV*)gv;
13970 }
13971 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13972 if (CvLEXICAL(cv) || CvNAMED(cv))
13973 return NULL;
13974 if (!CvANON(cv) || !gv)
13975 gv = CvGV(cv);
13976 return (CV*)gv;
13977
13978 } else {
13979 return cv;
13980 }
13981 }
13982
13983 /*
13984 =for apidoc ck_entersub_args_list
13985
13986 Performs the default fixup of the arguments part of an C<entersub>
13987 op tree. This consists of applying list context to each of the
13988 argument ops. This is the standard treatment used on a call marked
13989 with C<&>, or a method call, or a call through a subroutine reference,
13990 or any other call where the callee can't be identified at compile time,
13991 or a call where the callee has no prototype.
13992
13993 =cut
13994 */
13995
13996 OP *
Perl_ck_entersub_args_list(pTHX_ OP * entersubop)13997 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13998 {
13999 OP *aop;
14000
14001 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14002
14003 aop = cUNOPx(entersubop)->op_first;
14004 if (!OpHAS_SIBLING(aop))
14005 aop = cUNOPx(aop)->op_first;
14006 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14007 /* skip the extra attributes->import() call implicitly added in
14008 * something like foo(my $x : bar)
14009 */
14010 if ( aop->op_type == OP_ENTERSUB
14011 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14012 )
14013 continue;
14014 list(aop);
14015 op_lvalue(aop, OP_ENTERSUB);
14016 }
14017 return entersubop;
14018 }
14019
14020 /*
14021 =for apidoc ck_entersub_args_proto
14022
14023 Performs the fixup of the arguments part of an C<entersub> op tree
14024 based on a subroutine prototype. This makes various modifications to
14025 the argument ops, from applying context up to inserting C<refgen> ops,
14026 and checking the number and syntactic types of arguments, as directed by
14027 the prototype. This is the standard treatment used on a subroutine call,
14028 not marked with C<&>, where the callee can be identified at compile time
14029 and has a prototype.
14030
14031 C<protosv> supplies the subroutine prototype to be applied to the call.
14032 It may be a normal defined scalar, of which the string value will be used.
14033 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14034 that has been cast to C<SV*>) which has a prototype. The prototype
14035 supplied, in whichever form, does not need to match the actual callee
14036 referenced by the op tree.
14037
14038 If the argument ops disagree with the prototype, for example by having
14039 an unacceptable number of arguments, a valid op tree is returned anyway.
14040 The error is reflected in the parser state, normally resulting in a single
14041 exception at the top level of parsing which covers all the compilation
14042 errors that occurred. In the error message, the callee is referred to
14043 by the name defined by the C<namegv> parameter.
14044
14045 =cut
14046 */
14047
14048 OP *
Perl_ck_entersub_args_proto(pTHX_ OP * entersubop,GV * namegv,SV * protosv)14049 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14050 {
14051 STRLEN proto_len;
14052 const char *proto, *proto_end;
14053 OP *aop, *prev, *cvop, *parent;
14054 int optional = 0;
14055 I32 arg = 0;
14056 I32 contextclass = 0;
14057 const char *e = NULL;
14058 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14059 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14060 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14061 "flags=%lx", (unsigned long) SvFLAGS(protosv));
14062 if (SvTYPE(protosv) == SVt_PVCV)
14063 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14064 else proto = SvPV(protosv, proto_len);
14065 proto = S_strip_spaces(aTHX_ proto, &proto_len);
14066 proto_end = proto + proto_len;
14067 parent = entersubop;
14068 aop = cUNOPx(entersubop)->op_first;
14069 if (!OpHAS_SIBLING(aop)) {
14070 parent = aop;
14071 aop = cUNOPx(aop)->op_first;
14072 }
14073 prev = aop;
14074 aop = OpSIBLING(aop);
14075 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14076 while (aop != cvop) {
14077 OP* o3 = aop;
14078
14079 if (proto >= proto_end)
14080 {
14081 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14082 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14083 SVfARG(namesv)), SvUTF8(namesv));
14084 return entersubop;
14085 }
14086
14087 switch (*proto) {
14088 case ';':
14089 optional = 1;
14090 proto++;
14091 continue;
14092 case '_':
14093 /* _ must be at the end */
14094 if (proto[1] && !memCHRs(";@%", proto[1]))
14095 goto oops;
14096 /* FALLTHROUGH */
14097 case '$':
14098 proto++;
14099 arg++;
14100 scalar(aop);
14101 break;
14102 case '%':
14103 case '@':
14104 list(aop);
14105 arg++;
14106 break;
14107 case '&':
14108 proto++;
14109 arg++;
14110 if ( o3->op_type != OP_UNDEF
14111 && o3->op_type != OP_ANONCODE
14112 && (o3->op_type != OP_SREFGEN
14113 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14114 != OP_ANONCODE
14115 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14116 != OP_RV2CV)))
14117 bad_type_gv(arg, namegv, o3,
14118 arg == 1 ? "block or sub {}" : "sub {}");
14119 break;
14120 case '*':
14121 /* '*' allows any scalar type, including bareword */
14122 proto++;
14123 arg++;
14124 if (o3->op_type == OP_RV2GV)
14125 goto wrapref; /* autoconvert GLOB -> GLOBref */
14126 else if (o3->op_type == OP_CONST)
14127 o3->op_private &= ~OPpCONST_STRICT;
14128 scalar(aop);
14129 break;
14130 case '+':
14131 proto++;
14132 arg++;
14133 if (o3->op_type == OP_RV2AV ||
14134 o3->op_type == OP_PADAV ||
14135 o3->op_type == OP_RV2HV ||
14136 o3->op_type == OP_PADHV
14137 ) {
14138 goto wrapref;
14139 }
14140 scalar(aop);
14141 break;
14142 case '[': case ']':
14143 goto oops;
14144
14145 case '\\':
14146 proto++;
14147 arg++;
14148 again:
14149 switch (*proto++) {
14150 case '[':
14151 if (contextclass++ == 0) {
14152 e = (char *) memchr(proto, ']', proto_end - proto);
14153 if (!e || e == proto)
14154 goto oops;
14155 }
14156 else
14157 goto oops;
14158 goto again;
14159
14160 case ']':
14161 if (contextclass) {
14162 const char *p = proto;
14163 const char *const end = proto;
14164 contextclass = 0;
14165 while (*--p != '[')
14166 /* \[$] accepts any scalar lvalue */
14167 if (*p == '$'
14168 && Perl_op_lvalue_flags(aTHX_
14169 scalar(o3),
14170 OP_READ, /* not entersub */
14171 OP_LVALUE_NO_CROAK
14172 )) goto wrapref;
14173 bad_type_gv(arg, namegv, o3,
14174 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14175 } else
14176 goto oops;
14177 break;
14178 case '*':
14179 if (o3->op_type == OP_RV2GV)
14180 goto wrapref;
14181 if (!contextclass)
14182 bad_type_gv(arg, namegv, o3, "symbol");
14183 break;
14184 case '&':
14185 if (o3->op_type == OP_ENTERSUB
14186 && !(o3->op_flags & OPf_STACKED))
14187 goto wrapref;
14188 if (!contextclass)
14189 bad_type_gv(arg, namegv, o3, "subroutine");
14190 break;
14191 case '$':
14192 if (o3->op_type == OP_RV2SV ||
14193 o3->op_type == OP_PADSV ||
14194 o3->op_type == OP_HELEM ||
14195 o3->op_type == OP_AELEM)
14196 goto wrapref;
14197 if (!contextclass) {
14198 /* \$ accepts any scalar lvalue */
14199 if (Perl_op_lvalue_flags(aTHX_
14200 scalar(o3),
14201 OP_READ, /* not entersub */
14202 OP_LVALUE_NO_CROAK
14203 )) goto wrapref;
14204 bad_type_gv(arg, namegv, o3, "scalar");
14205 }
14206 break;
14207 case '@':
14208 if (o3->op_type == OP_RV2AV ||
14209 o3->op_type == OP_PADAV)
14210 {
14211 o3->op_flags &=~ OPf_PARENS;
14212 goto wrapref;
14213 }
14214 if (!contextclass)
14215 bad_type_gv(arg, namegv, o3, "array");
14216 break;
14217 case '%':
14218 if (o3->op_type == OP_RV2HV ||
14219 o3->op_type == OP_PADHV)
14220 {
14221 o3->op_flags &=~ OPf_PARENS;
14222 goto wrapref;
14223 }
14224 if (!contextclass)
14225 bad_type_gv(arg, namegv, o3, "hash");
14226 break;
14227 wrapref:
14228 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14229 OP_REFGEN, 0);
14230 if (contextclass && e) {
14231 proto = e + 1;
14232 contextclass = 0;
14233 }
14234 break;
14235 default: goto oops;
14236 }
14237 if (contextclass)
14238 goto again;
14239 break;
14240 case ' ':
14241 proto++;
14242 continue;
14243 default:
14244 oops: {
14245 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14246 SVfARG(cv_name((CV *)namegv, NULL, 0)),
14247 SVfARG(protosv));
14248 }
14249 }
14250
14251 op_lvalue(aop, OP_ENTERSUB);
14252 prev = aop;
14253 aop = OpSIBLING(aop);
14254 }
14255 if (aop == cvop && *proto == '_') {
14256 /* generate an access to $_ */
14257 op_sibling_splice(parent, prev, 0, newDEFSVOP());
14258 }
14259 if (!optional && proto_end > proto &&
14260 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14261 {
14262 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14263 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14264 SVfARG(namesv)), SvUTF8(namesv));
14265 }
14266 return entersubop;
14267 }
14268
14269 /*
14270 =for apidoc ck_entersub_args_proto_or_list
14271
14272 Performs the fixup of the arguments part of an C<entersub> op tree either
14273 based on a subroutine prototype or using default list-context processing.
14274 This is the standard treatment used on a subroutine call, not marked
14275 with C<&>, where the callee can be identified at compile time.
14276
14277 C<protosv> supplies the subroutine prototype to be applied to the call,
14278 or indicates that there is no prototype. It may be a normal scalar,
14279 in which case if it is defined then the string value will be used
14280 as a prototype, and if it is undefined then there is no prototype.
14281 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14282 that has been cast to C<SV*>), of which the prototype will be used if it
14283 has one. The prototype (or lack thereof) supplied, in whichever form,
14284 does not need to match the actual callee referenced by the op tree.
14285
14286 If the argument ops disagree with the prototype, for example by having
14287 an unacceptable number of arguments, a valid op tree is returned anyway.
14288 The error is reflected in the parser state, normally resulting in a single
14289 exception at the top level of parsing which covers all the compilation
14290 errors that occurred. In the error message, the callee is referred to
14291 by the name defined by the C<namegv> parameter.
14292
14293 =cut
14294 */
14295
14296 OP *
Perl_ck_entersub_args_proto_or_list(pTHX_ OP * entersubop,GV * namegv,SV * protosv)14297 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14298 GV *namegv, SV *protosv)
14299 {
14300 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14301 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14302 return ck_entersub_args_proto(entersubop, namegv, protosv);
14303 else
14304 return ck_entersub_args_list(entersubop);
14305 }
14306
14307 OP *
Perl_ck_entersub_args_core(pTHX_ OP * entersubop,GV * namegv,SV * protosv)14308 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14309 {
14310 IV cvflags = SvIVX(protosv);
14311 int opnum = cvflags & 0xffff;
14312 OP *aop = cUNOPx(entersubop)->op_first;
14313
14314 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14315
14316 if (!opnum) {
14317 OP *cvop;
14318 if (!OpHAS_SIBLING(aop))
14319 aop = cUNOPx(aop)->op_first;
14320 aop = OpSIBLING(aop);
14321 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14322 if (aop != cvop) {
14323 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14324 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14325 SVfARG(namesv)), SvUTF8(namesv));
14326 }
14327
14328 op_free(entersubop);
14329 switch(cvflags >> 16) {
14330 case 'F': return newSVOP(OP_CONST, 0,
14331 newSVpv(CopFILE(PL_curcop),0));
14332 case 'L': return newSVOP(
14333 OP_CONST, 0,
14334 Perl_newSVpvf(aTHX_
14335 "%" LINE_Tf, CopLINE(PL_curcop)
14336 )
14337 );
14338 case 'P': return newSVOP(OP_CONST, 0,
14339 (PL_curstash
14340 ? newSVhek(HvNAME_HEK(PL_curstash))
14341 : &PL_sv_undef
14342 )
14343 );
14344 }
14345 NOT_REACHED; /* NOTREACHED */
14346 }
14347 else {
14348 OP *prev, *cvop, *first, *parent;
14349 U32 flags = 0;
14350
14351 parent = entersubop;
14352 if (!OpHAS_SIBLING(aop)) {
14353 parent = aop;
14354 aop = cUNOPx(aop)->op_first;
14355 }
14356
14357 first = prev = aop;
14358 aop = OpSIBLING(aop);
14359 /* find last sibling */
14360 for (cvop = aop;
14361 OpHAS_SIBLING(cvop);
14362 prev = cvop, cvop = OpSIBLING(cvop))
14363 ;
14364 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14365 /* Usually, OPf_SPECIAL on an op with no args means that it had
14366 * parens, but these have their own meaning for that flag: */
14367 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14368 && opnum != OP_DELETE && opnum != OP_EXISTS)
14369 flags |= OPf_SPECIAL;
14370 /* excise cvop from end of sibling chain */
14371 op_sibling_splice(parent, prev, 1, NULL);
14372 op_free(cvop);
14373 if (aop == cvop) aop = NULL;
14374
14375 /* detach remaining siblings from the first sibling, then
14376 * dispose of original optree */
14377
14378 if (aop)
14379 op_sibling_splice(parent, first, -1, NULL);
14380 op_free(entersubop);
14381
14382 if (cvflags == (OP_ENTEREVAL | (1<<16)))
14383 flags |= OPpEVAL_BYTES <<8;
14384
14385 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14386 case OA_UNOP:
14387 case OA_BASEOP_OR_UNOP:
14388 case OA_FILESTATOP:
14389 if (!aop)
14390 return newOP(opnum,flags); /* zero args */
14391 if (aop == prev)
14392 return newUNOP(opnum,flags,aop); /* one arg */
14393 /* too many args */
14394 /* FALLTHROUGH */
14395 case OA_BASEOP:
14396 if (aop) {
14397 SV *namesv;
14398 OP *nextop;
14399
14400 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14401 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14402 SVfARG(namesv)), SvUTF8(namesv));
14403 while (aop) {
14404 nextop = OpSIBLING(aop);
14405 op_free(aop);
14406 aop = nextop;
14407 }
14408
14409 }
14410 return opnum == OP_RUNCV
14411 ? newSVOP(OP_RUNCV, 0, &PL_sv_undef)
14412 : newOP(opnum,0);
14413 default:
14414 return op_convert_list(opnum,0,aop);
14415 }
14416 }
14417 NOT_REACHED; /* NOTREACHED */
14418 return entersubop;
14419 }
14420
14421 /*
14422 =for apidoc cv_get_call_checker_flags
14423
14424 Retrieves the function that will be used to fix up a call to C<cv>.
14425 Specifically, the function is applied to an C<entersub> op tree for a
14426 subroutine call, not marked with C<&>, where the callee can be identified
14427 at compile time as C<cv>.
14428
14429 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14430 for it is returned in C<*ckobj_p>, and control flags are returned in
14431 C<*ckflags_p>. The function is intended to be called in this manner:
14432
14433 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14434
14435 In this call, C<entersubop> is a pointer to the C<entersub> op,
14436 which may be replaced by the check function, and C<namegv> supplies
14437 the name that should be used by the check function to refer
14438 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14439 It is permitted to apply the check function in non-standard situations,
14440 such as to a call to a different subroutine or to a method call.
14441
14442 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
14443 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14444 instead, anything that can be used as the first argument to L</cv_name>.
14445 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14446 check function requires C<namegv> to be a genuine GV.
14447
14448 By default, the check function is
14449 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14450 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14451 flag is clear. This implements standard prototype processing. It can
14452 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14453
14454 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14455 indicates that the caller only knows about the genuine GV version of
14456 C<namegv>, and accordingly the corresponding bit will always be set in
14457 C<*ckflags_p>, regardless of the check function's recorded requirements.
14458 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14459 indicates the caller knows about the possibility of passing something
14460 other than a GV as C<namegv>, and accordingly the corresponding bit may
14461 be either set or clear in C<*ckflags_p>, indicating the check function's
14462 recorded requirements.
14463
14464 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14465 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14466 (for which see above). All other bits should be clear.
14467
14468 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14469
14470 =for apidoc cv_get_call_checker
14471
14472 The original form of L</cv_get_call_checker_flags>, which does not return
14473 checker flags. When using a checker function returned by this function,
14474 it is only safe to call it with a genuine GV as its C<namegv> argument.
14475
14476 =cut
14477 */
14478
14479 void
Perl_cv_get_call_checker_flags(pTHX_ CV * cv,U32 gflags,Perl_call_checker * ckfun_p,SV ** ckobj_p,U32 * ckflags_p)14480 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14481 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14482 {
14483 MAGIC *callmg;
14484 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14485 PERL_UNUSED_CONTEXT;
14486 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14487 if (callmg) {
14488 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14489 *ckobj_p = callmg->mg_obj;
14490 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14491 } else {
14492 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14493 *ckobj_p = (SV*)cv;
14494 *ckflags_p = gflags & MGf_REQUIRE_GV;
14495 }
14496 }
14497
14498 void
Perl_cv_get_call_checker(pTHX_ CV * cv,Perl_call_checker * ckfun_p,SV ** ckobj_p)14499 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14500 {
14501 U32 ckflags;
14502 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14503 PERL_UNUSED_CONTEXT;
14504 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14505 &ckflags);
14506 }
14507
14508 /*
14509 =for apidoc cv_set_call_checker_flags
14510
14511 Sets the function that will be used to fix up a call to C<cv>.
14512 Specifically, the function is applied to an C<entersub> op tree for a
14513 subroutine call, not marked with C<&>, where the callee can be identified
14514 at compile time as C<cv>.
14515
14516 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14517 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14518 The function should be defined like this:
14519
14520 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14521
14522 It is intended to be called in this manner:
14523
14524 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14525
14526 In this call, C<entersubop> is a pointer to the C<entersub> op,
14527 which may be replaced by the check function, and C<namegv> supplies
14528 the name that should be used by the check function to refer
14529 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14530 It is permitted to apply the check function in non-standard situations,
14531 such as to a call to a different subroutine or to a method call.
14532
14533 C<namegv> may not actually be a GV. For efficiency, perl may pass a
14534 CV or other SV instead. Whatever is passed can be used as the first
14535 argument to L</cv_name>. You can force perl to pass a GV by including
14536 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14537
14538 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14539 bit currently has a defined meaning (for which see above). All other
14540 bits should be clear.
14541
14542 The current setting for a particular CV can be retrieved by
14543 L</cv_get_call_checker_flags>.
14544
14545 =for apidoc cv_set_call_checker
14546
14547 The original form of L</cv_set_call_checker_flags>, which passes it the
14548 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
14549 of that flag setting is that the check function is guaranteed to get a
14550 genuine GV as its C<namegv> argument.
14551
14552 =cut
14553 */
14554
14555 void
Perl_cv_set_call_checker(pTHX_ CV * cv,Perl_call_checker ckfun,SV * ckobj)14556 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14557 {
14558 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14559 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14560 }
14561
14562 void
Perl_cv_set_call_checker_flags(pTHX_ CV * cv,Perl_call_checker ckfun,SV * ckobj,U32 ckflags)14563 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14564 SV *ckobj, U32 ckflags)
14565 {
14566 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14567 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
14568 if (SvMAGICAL((SV*)cv))
14569 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
14570 } else {
14571 MAGIC *callmg;
14572 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
14573 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
14574 assert(callmg);
14575 if (callmg->mg_flags & MGf_REFCOUNTED) {
14576 SvREFCNT_dec(callmg->mg_obj);
14577 callmg->mg_flags &= ~MGf_REFCOUNTED;
14578 }
14579 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
14580 callmg->mg_obj = ckobj;
14581 if (ckobj != (SV*)cv) {
14582 SvREFCNT_inc_simple_void_NN(ckobj);
14583 callmg->mg_flags |= MGf_REFCOUNTED;
14584 }
14585 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
14586 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
14587 }
14588 }
14589
14590 static void
S_entersub_alloc_targ(pTHX_ OP * const o)14591 S_entersub_alloc_targ(pTHX_ OP * const o)
14592 {
14593 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14594 o->op_private |= OPpENTERSUB_HASTARG;
14595 }
14596
14597 OP *
Perl_ck_subr(pTHX_ OP * o)14598 Perl_ck_subr(pTHX_ OP *o)
14599 {
14600 OP *aop, *cvop;
14601 CV *cv;
14602 GV *namegv;
14603 SV **const_class = NULL;
14604
14605 PERL_ARGS_ASSERT_CK_SUBR;
14606
14607 aop = cUNOPx(o)->op_first;
14608 if (!OpHAS_SIBLING(aop))
14609 aop = cUNOPx(aop)->op_first;
14610 aop = OpSIBLING(aop);
14611 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14612 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
14613 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
14614
14615 o->op_private &= ~1;
14616 o->op_private |= (PL_hints & HINT_STRICT_REFS);
14617 if (PERLDB_SUB && PL_curstash != PL_debstash)
14618 o->op_private |= OPpENTERSUB_DB;
14619 switch (cvop->op_type) {
14620 case OP_RV2CV:
14621 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
14622 op_null(cvop);
14623 break;
14624 case OP_METHOD:
14625 case OP_METHOD_NAMED:
14626 case OP_METHOD_SUPER:
14627 case OP_METHOD_REDIR:
14628 case OP_METHOD_REDIR_SUPER:
14629 o->op_flags |= OPf_REF;
14630 if (aop->op_type == OP_CONST) {
14631 aop->op_private &= ~OPpCONST_STRICT;
14632 const_class = &cSVOPx(aop)->op_sv;
14633 }
14634 else if (aop->op_type == OP_LIST) {
14635 OP * const sib = OpSIBLING(cUNOPx(aop)->op_first);
14636 if (sib && sib->op_type == OP_CONST) {
14637 sib->op_private &= ~OPpCONST_STRICT;
14638 const_class = &cSVOPx(sib)->op_sv;
14639 }
14640 }
14641 /* make class name a shared cow string to speedup method calls */
14642 /* constant string might be replaced with object, f.e. bigint */
14643 if (const_class && SvPOK(*const_class)) {
14644 STRLEN len;
14645 const char* str = SvPV(*const_class, len);
14646 if (len) {
14647 SV* const shared = newSVpvn_share(
14648 str, SvUTF8(*const_class)
14649 ? -(SSize_t)len : (SSize_t)len,
14650 0
14651 );
14652 if (SvREADONLY(*const_class))
14653 SvREADONLY_on(shared);
14654 SvREFCNT_dec(*const_class);
14655 *const_class = shared;
14656 }
14657 }
14658 break;
14659 }
14660
14661 if (!cv) {
14662 S_entersub_alloc_targ(aTHX_ o);
14663 return ck_entersub_args_list(o);
14664 } else {
14665 Perl_call_checker ckfun;
14666 SV *ckobj;
14667 U32 ckflags;
14668 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
14669 if (CvISXSUB(cv) || !CvROOT(cv))
14670 S_entersub_alloc_targ(aTHX_ o);
14671 if (!namegv) {
14672 /* The original call checker API guarantees that a GV will
14673 be provided with the right name. So, if the old API was
14674 used (or the REQUIRE_GV flag was passed), we have to reify
14675 the CV’s GV, unless this is an anonymous sub. This is not
14676 ideal for lexical subs, as its stringification will include
14677 the package. But it is the best we can do. */
14678 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
14679 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
14680 namegv = CvGV(cv);
14681 }
14682 else namegv = MUTABLE_GV(cv);
14683 /* After a syntax error in a lexical sub, the cv that
14684 rv2cv_op_cv returns may be a nameless stub. */
14685 if (!namegv) return ck_entersub_args_list(o);
14686
14687 }
14688 return ckfun(aTHX_ o, namegv, ckobj);
14689 }
14690 }
14691
14692 OP *
Perl_ck_svconst(pTHX_ OP * o)14693 Perl_ck_svconst(pTHX_ OP *o)
14694 {
14695 SV * const sv = cSVOPo->op_sv;
14696 PERL_ARGS_ASSERT_CK_SVCONST;
14697 PERL_UNUSED_CONTEXT;
14698 #ifdef PERL_COPY_ON_WRITE
14699 /* Since the read-only flag may be used to protect a string buffer, we
14700 cannot do copy-on-write with existing read-only scalars that are not
14701 already copy-on-write scalars. To allow $_ = "hello" to do COW with
14702 that constant, mark the constant as COWable here, if it is not
14703 already read-only. */
14704 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
14705 SvIsCOW_on(sv);
14706 CowREFCNT(sv) = 0;
14707 # ifdef PERL_DEBUG_READONLY_COW
14708 sv_buf_to_ro(sv);
14709 # endif
14710 }
14711 #endif
14712 SvREADONLY_on(sv);
14713 return o;
14714 }
14715
14716 OP *
Perl_ck_trunc(pTHX_ OP * o)14717 Perl_ck_trunc(pTHX_ OP *o)
14718 {
14719 PERL_ARGS_ASSERT_CK_TRUNC;
14720
14721 if (o->op_flags & OPf_KIDS) {
14722 SVOP *kid = cSVOPx(cUNOPo->op_first);
14723
14724 if (kid->op_type == OP_NULL)
14725 kid = cSVOPx(OpSIBLING(kid));
14726 if (kid && kid->op_type == OP_CONST &&
14727 (kid->op_private & OPpCONST_BARE) &&
14728 !kid->op_folded)
14729 {
14730 o->op_flags |= OPf_SPECIAL;
14731 kid->op_private &= ~OPpCONST_STRICT;
14732 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
14733 no_bareword_filehandle(SvPVX(cSVOPx_sv(kid)));
14734 }
14735 }
14736 }
14737 return ck_fun(o);
14738 }
14739
14740 OP *
Perl_ck_substr(pTHX_ OP * o)14741 Perl_ck_substr(pTHX_ OP *o)
14742 {
14743 PERL_ARGS_ASSERT_CK_SUBSTR;
14744
14745 o = ck_fun(o);
14746 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
14747 OP *kid = cLISTOPo->op_first;
14748
14749 if (kid->op_type == OP_NULL)
14750 kid = OpSIBLING(kid);
14751 if (kid)
14752 /* Historically, substr(delete $foo{bar},...) has been allowed
14753 with 4-arg substr. Keep it working by applying entersub
14754 lvalue context. */
14755 op_lvalue(kid, OP_ENTERSUB);
14756
14757 }
14758 return o;
14759 }
14760
14761 OP *
Perl_ck_tell(pTHX_ OP * o)14762 Perl_ck_tell(pTHX_ OP *o)
14763 {
14764 PERL_ARGS_ASSERT_CK_TELL;
14765 o = ck_fun(o);
14766 if (o->op_flags & OPf_KIDS) {
14767 OP *kid = cLISTOPo->op_first;
14768 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
14769 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
14770 }
14771 return o;
14772 }
14773
14774 PERL_STATIC_INLINE OP *
S_last_non_null_kid(OP * o)14775 S_last_non_null_kid(OP *o) {
14776 OP *last = NULL;
14777 if (cUNOPo->op_flags & OPf_KIDS) {
14778 OP *k = cLISTOPo->op_first;
14779 while (k) {
14780 if (k->op_type != OP_NULL) {
14781 last = k;
14782 }
14783 k = OpSIBLING(k);
14784 }
14785 }
14786
14787 return last;
14788 }
14789
14790 OP *
Perl_ck_each(pTHX_ OP * o)14791 Perl_ck_each(pTHX_ OP *o)
14792 {
14793 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
14794 const unsigned orig_type = o->op_type;
14795
14796 PERL_ARGS_ASSERT_CK_EACH;
14797
14798 if (kid) {
14799 switch (kid->op_type) {
14800 case OP_PADHV:
14801 break;
14802
14803 case OP_RV2HV:
14804 /* Catch out an anonhash here, since the behaviour might be
14805 * confusing.
14806 *
14807 * The typical tree is:
14808 *
14809 * rv2hv
14810 * scope
14811 * null
14812 * anonhash
14813 *
14814 * If the contents of the block is more complex you might get:
14815 *
14816 * rv2hv
14817 * leave
14818 * enter
14819 * ...
14820 * anonhash
14821 *
14822 * Similarly for the anonlist version below.
14823 */
14824 if (orig_type == OP_EACH &&
14825 ckWARN(WARN_SYNTAX) &&
14826 (cUNOPx(kid)->op_flags & OPf_KIDS) &&
14827 ( cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
14828 cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
14829 (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
14830 /* look for last non-null kid, since we might have:
14831 each %{ some code ; +{ anon hash } }
14832 */
14833 OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
14834 if (k && k->op_type == OP_ANONHASH) {
14835 /* diag_listed_as: each on anonymous %s will always start from the beginning */
14836 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous hash will always start from the beginning");
14837 }
14838 }
14839 break;
14840 case OP_RV2AV:
14841 if (orig_type == OP_EACH &&
14842 ckWARN(WARN_SYNTAX) &&
14843 (cUNOPx(kid)->op_flags & OPf_KIDS) &&
14844 (cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
14845 cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
14846 (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
14847 OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
14848 if (k && k->op_type == OP_ANONLIST) {
14849 /* diag_listed_as: each on anonymous %s will always start from the beginning */
14850 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous array will always start from the beginning");
14851 }
14852 }
14853 /* FALLTHROUGH */
14854 case OP_PADAV:
14855 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
14856 : orig_type == OP_KEYS ? OP_AKEYS
14857 : OP_AVALUES);
14858 break;
14859 case OP_CONST:
14860 if (kid->op_private == OPpCONST_BARE
14861 || !SvROK(cSVOPx_sv(kid))
14862 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
14863 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
14864 )
14865 goto bad;
14866 /* FALLTHROUGH */
14867 default:
14868 qerror(Perl_mess(aTHX_
14869 "Experimental %s on scalar is now forbidden",
14870 PL_op_desc[orig_type]));
14871 bad:
14872 bad_type_pv(1, "hash or array", o, kid);
14873 return o;
14874 }
14875 }
14876 return ck_fun(o);
14877 }
14878
14879 OP *
Perl_ck_length(pTHX_ OP * o)14880 Perl_ck_length(pTHX_ OP *o)
14881 {
14882 PERL_ARGS_ASSERT_CK_LENGTH;
14883
14884 o = ck_fun(o);
14885
14886 if (ckWARN(WARN_SYNTAX)) {
14887 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
14888
14889 if (kid) {
14890 SV *name = NULL;
14891 const bool hash = kid->op_type == OP_PADHV
14892 || kid->op_type == OP_RV2HV;
14893 switch (kid->op_type) {
14894 case OP_PADHV:
14895 case OP_PADAV:
14896 case OP_RV2HV:
14897 case OP_RV2AV:
14898 name = op_varname(kid);
14899 break;
14900 default:
14901 return o;
14902 }
14903 if (name)
14904 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14905 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
14906 ")\"?)",
14907 SVfARG(name), hash ? "keys " : "", SVfARG(name)
14908 );
14909 else if (hash)
14910 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14911 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14912 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
14913 else
14914 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14915 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14916 "length() used on @array (did you mean \"scalar(@array)\"?)");
14917 }
14918 }
14919
14920 return o;
14921 }
14922
14923
14924 OP *
Perl_ck_isa(pTHX_ OP * o)14925 Perl_ck_isa(pTHX_ OP *o)
14926 {
14927 OP *classop = cBINOPo->op_last;
14928
14929 PERL_ARGS_ASSERT_CK_ISA;
14930
14931 /* Convert barename into PV */
14932 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
14933 /* TODO: Optionally convert package to raw HV here */
14934 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
14935 }
14936
14937 return o;
14938 }
14939
14940
14941 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14942 and modify the optree to make them work inplace */
14943
14944 STATIC void
S_inplace_aassign(pTHX_ OP * o)14945 S_inplace_aassign(pTHX_ OP *o) {
14946
14947 OP *modop, *modop_pushmark;
14948 OP *oright;
14949 OP *oleft, *oleft_pushmark;
14950
14951 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14952
14953 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14954
14955 assert(cUNOPo->op_first->op_type == OP_NULL);
14956 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14957 assert(modop_pushmark->op_type == OP_PUSHMARK);
14958 modop = OpSIBLING(modop_pushmark);
14959
14960 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14961 return;
14962
14963 /* no other operation except sort/reverse */
14964 if (OpHAS_SIBLING(modop))
14965 return;
14966
14967 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14968 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14969
14970 if (modop->op_flags & OPf_STACKED) {
14971 /* skip sort subroutine/block */
14972 assert(oright->op_type == OP_NULL);
14973 oright = OpSIBLING(oright);
14974 }
14975
14976 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14977 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14978 assert(oleft_pushmark->op_type == OP_PUSHMARK);
14979 oleft = OpSIBLING(oleft_pushmark);
14980
14981 /* Check the lhs is an array */
14982 if (!oleft ||
14983 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14984 || OpHAS_SIBLING(oleft)
14985 || (oleft->op_private & OPpLVAL_INTRO)
14986 )
14987 return;
14988
14989 /* Only one thing on the rhs */
14990 if (OpHAS_SIBLING(oright))
14991 return;
14992
14993 /* check the array is the same on both sides */
14994 if (oleft->op_type == OP_RV2AV) {
14995 if (oright->op_type != OP_RV2AV
14996 || !cUNOPx(oright)->op_first
14997 || cUNOPx(oright)->op_first->op_type != OP_GV
14998 || cUNOPx(oleft )->op_first->op_type != OP_GV
14999 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15000 cGVOPx_gv(cUNOPx(oright)->op_first)
15001 )
15002 return;
15003 }
15004 else if (oright->op_type != OP_PADAV
15005 || oright->op_targ != oleft->op_targ
15006 )
15007 return;
15008
15009 /* This actually is an inplace assignment */
15010
15011 modop->op_private |= OPpSORT_INPLACE;
15012
15013 /* transfer MODishness etc from LHS arg to RHS arg */
15014 oright->op_flags = oleft->op_flags;
15015
15016 /* remove the aassign op and the lhs */
15017 op_null(o);
15018 op_null(oleft_pushmark);
15019 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15020 op_null(cUNOPx(oleft)->op_first);
15021 op_null(oleft);
15022 }
15023
15024
15025 /*
15026 =for apidoc_section $custom
15027
15028 =for apidoc Perl_custom_op_xop
15029 Return the XOP structure for a given custom op. This macro should be
15030 considered internal to C<OP_NAME> and the other access macros: use them instead.
15031 This macro does call a function. Prior
15032 to 5.19.6, this was implemented as a
15033 function.
15034
15035 =cut
15036 */
15037
15038
15039 /* use PERL_MAGIC_ext to call a function to free the xop structure when
15040 * freeing PL_custom_ops */
15041
15042 static int
custom_op_register_free(pTHX_ SV * sv,MAGIC * mg)15043 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
15044 {
15045 XOP *xop;
15046
15047 PERL_UNUSED_ARG(mg);
15048 xop = INT2PTR(XOP *, SvIV(sv));
15049 Safefree(xop->xop_name);
15050 Safefree(xop->xop_desc);
15051 Safefree(xop);
15052 return 0;
15053 }
15054
15055
15056 static const MGVTBL custom_op_register_vtbl = {
15057 0, /* get */
15058 0, /* set */
15059 0, /* len */
15060 0, /* clear */
15061 custom_op_register_free, /* free */
15062 0, /* copy */
15063 0, /* dup */
15064 #ifdef MGf_LOCAL
15065 0, /* local */
15066 #endif
15067 };
15068
15069
15070 XOPRETANY
Perl_custom_op_get_field(pTHX_ const OP * o,const xop_flags_enum field)15071 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
15072 {
15073 SV *keysv;
15074 HE *he = NULL;
15075 XOP *xop;
15076
15077 static const XOP xop_null = { 0, 0, 0, 0, 0 };
15078
15079 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
15080 assert(o->op_type == OP_CUSTOM);
15081
15082 /* This is wrong. It assumes a function pointer can be cast to IV,
15083 * which isn't guaranteed, but this is what the old custom OP code
15084 * did. In principle it should be safer to Copy the bytes of the
15085 * pointer into a PV: since the new interface is hidden behind
15086 * functions, this can be changed later if necessary. */
15087 /* Change custom_op_xop if this ever happens */
15088 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
15089
15090 if (PL_custom_ops)
15091 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
15092
15093 /* See if the op isn't registered, but its name *is* registered.
15094 * That implies someone is using the pre-5.14 API,where only name and
15095 * description could be registered. If so, fake up a real
15096 * registration.
15097 * We only check for an existing name, and assume no one will have
15098 * just registered a desc */
15099 if (!he && PL_custom_op_names &&
15100 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
15101 ) {
15102 const char *pv;
15103 STRLEN l;
15104
15105 /* XXX does all this need to be shared mem? */
15106 Newxz(xop, 1, XOP);
15107 pv = SvPV(HeVAL(he), l);
15108 XopENTRY_set(xop, xop_name, savepvn(pv, l));
15109 if (PL_custom_op_descs &&
15110 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
15111 ) {
15112 pv = SvPV(HeVAL(he), l);
15113 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
15114 }
15115 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
15116 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
15117 /* add magic to the SV so that the xop struct (pointed to by
15118 * SvIV(sv)) is freed. Normally a static xop is registered, but
15119 * for this backcompat hack, we've alloced one */
15120 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
15121 &custom_op_register_vtbl, NULL, 0);
15122
15123 }
15124 else {
15125 if (!he)
15126 xop = (XOP *)&xop_null;
15127 else
15128 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
15129 }
15130
15131 {
15132 XOPRETANY any;
15133 if(field == XOPe_xop_ptr) {
15134 any.xop_ptr = xop;
15135 } else {
15136 const U32 flags = XopFLAGS(xop);
15137 if(flags & field) {
15138 switch(field) {
15139 case XOPe_xop_name:
15140 any.xop_name = xop->xop_name;
15141 break;
15142 case XOPe_xop_desc:
15143 any.xop_desc = xop->xop_desc;
15144 break;
15145 case XOPe_xop_class:
15146 any.xop_class = xop->xop_class;
15147 break;
15148 case XOPe_xop_peep:
15149 any.xop_peep = xop->xop_peep;
15150 break;
15151 default:
15152 field_panic:
15153 Perl_croak(aTHX_
15154 "panic: custom_op_get_field(): invalid field %d\n",
15155 (int)field);
15156 break;
15157 }
15158 } else {
15159 switch(field) {
15160 case XOPe_xop_name:
15161 any.xop_name = XOPd_xop_name;
15162 break;
15163 case XOPe_xop_desc:
15164 any.xop_desc = XOPd_xop_desc;
15165 break;
15166 case XOPe_xop_class:
15167 any.xop_class = XOPd_xop_class;
15168 break;
15169 case XOPe_xop_peep:
15170 any.xop_peep = XOPd_xop_peep;
15171 break;
15172 default:
15173 goto field_panic;
15174 break;
15175 }
15176 }
15177 }
15178 return any;
15179 }
15180 }
15181
15182 /*
15183 =for apidoc custom_op_register
15184 Register a custom op. See L<perlguts/"Custom Operators">.
15185
15186 =cut
15187 */
15188
15189 void
Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr,const XOP * xop)15190 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
15191 {
15192 SV *keysv;
15193
15194 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
15195
15196 /* see the comment in custom_op_xop */
15197 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
15198
15199 if (!PL_custom_ops)
15200 PL_custom_ops = newHV();
15201
15202 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
15203 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
15204 }
15205
15206 /*
15207
15208 =for apidoc core_prototype
15209
15210 This function assigns the prototype of the named core function to C<sv>, or
15211 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
15212 C<NULL> if the core function has no prototype. C<code> is a code as returned
15213 by C<keyword()>. It must not be equal to 0.
15214
15215 =cut
15216 */
15217
15218 SV *
Perl_core_prototype(pTHX_ SV * sv,const char * name,const int code,int * const opnum)15219 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
15220 int * const opnum)
15221 {
15222 int i = 0, n = 0, seen_question = 0, defgv = 0;
15223 I32 oa;
15224 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
15225 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
15226 bool nullret = FALSE;
15227
15228 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
15229
15230 assert (code);
15231
15232 if (!sv) sv = sv_newmortal();
15233
15234 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
15235
15236 switch (code < 0 ? -code : code) {
15237 case KEY_and : case KEY_chop: case KEY_chomp:
15238 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
15239 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
15240 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
15241 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
15242 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
15243 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
15244 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
15245 case KEY_x : case KEY_xor :
15246 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
15247 case KEY_glob: retsetpvs("_;", OP_GLOB);
15248 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
15249 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
15250 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
15251 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
15252 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
15253 retsetpvs("", 0);
15254 case KEY_evalbytes:
15255 name = "entereval"; break;
15256 case KEY_readpipe:
15257 name = "backtick";
15258 }
15259
15260 #undef retsetpvs
15261
15262 findopnum:
15263 while (i < MAXO) { /* The slow way. */
15264 if (strEQ(name, PL_op_name[i])
15265 || strEQ(name, PL_op_desc[i]))
15266 {
15267 if (nullret) { assert(opnum); *opnum = i; return NULL; }
15268 goto found;
15269 }
15270 i++;
15271 }
15272 return NULL;
15273 found:
15274 defgv = PL_opargs[i] & OA_DEFGV;
15275 oa = PL_opargs[i] >> OASHIFT;
15276 while (oa) {
15277 if (oa & OA_OPTIONAL && !seen_question && (
15278 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
15279 )) {
15280 seen_question = 1;
15281 str[n++] = ';';
15282 }
15283 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
15284 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
15285 /* But globs are already references (kinda) */
15286 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
15287 ) {
15288 str[n++] = '\\';
15289 }
15290 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
15291 && !scalar_mod_type(NULL, i)) {
15292 str[n++] = '[';
15293 str[n++] = '$';
15294 str[n++] = '@';
15295 str[n++] = '%';
15296 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
15297 str[n++] = '*';
15298 str[n++] = ']';
15299 }
15300 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
15301 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
15302 str[n-1] = '_'; defgv = 0;
15303 }
15304 oa = oa >> 4;
15305 }
15306 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
15307 str[n++] = '\0';
15308 sv_setpvn(sv, str, n - 1);
15309 if (opnum) *opnum = i;
15310 return sv;
15311 }
15312
15313 OP *
Perl_coresub_op(pTHX_ SV * const coreargssv,const int code,const int opnum)15314 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
15315 const int opnum)
15316 {
15317 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
15318 newSVOP(OP_COREARGS,0,coreargssv);
15319 OP *o;
15320
15321 PERL_ARGS_ASSERT_CORESUB_OP;
15322
15323 switch(opnum) {
15324 case 0:
15325 return op_append_elem(OP_LINESEQ,
15326 argop,
15327 newSLICEOP(0,
15328 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
15329 newOP(OP_CALLER,0)
15330 )
15331 );
15332 case OP_EACH:
15333 case OP_KEYS:
15334 case OP_VALUES:
15335 o = newUNOP(OP_AVHVSWITCH,0,argop);
15336 o->op_private = opnum-OP_EACH;
15337 return o;
15338 case OP_SELECT: /* which represents OP_SSELECT as well */
15339 if (code)
15340 return newCONDOP(
15341 0,
15342 newBINOP(OP_GT, 0,
15343 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
15344 newSVOP(OP_CONST, 0, newSVuv(1))
15345 ),
15346 coresub_op(newSVuv((UV)OP_SSELECT), 0,
15347 OP_SSELECT),
15348 coresub_op(coreargssv, 0, OP_SELECT)
15349 );
15350 /* FALLTHROUGH */
15351 default:
15352 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
15353 case OA_BASEOP:
15354 return op_append_elem(
15355 OP_LINESEQ, argop,
15356 newOP(opnum,
15357 opnum == OP_WANTARRAY || opnum == OP_RUNCV
15358 ? OPpOFFBYONE << 8 : 0)
15359 );
15360 case OA_BASEOP_OR_UNOP:
15361 if (opnum == OP_ENTEREVAL) {
15362 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
15363 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
15364 }
15365 else o = newUNOP(opnum,0,argop);
15366 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
15367 else {
15368 onearg:
15369 if (is_handle_constructor(o, 1))
15370 argop->op_private |= OPpCOREARGS_DEREF1;
15371 if (scalar_mod_type(NULL, opnum))
15372 argop->op_private |= OPpCOREARGS_SCALARMOD;
15373 }
15374 return o;
15375 default:
15376 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
15377 if (is_handle_constructor(o, 2))
15378 argop->op_private |= OPpCOREARGS_DEREF2;
15379 if (opnum == OP_SUBSTR) {
15380 o->op_private |= OPpMAYBE_LVSUB;
15381 return o;
15382 }
15383 else goto onearg;
15384 }
15385 }
15386 }
15387
15388 void
Perl_report_redefined_cv(pTHX_ const SV * name,const CV * old_cv,SV * const * new_const_svp)15389 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
15390 SV * const *new_const_svp)
15391 {
15392 const char *hvname;
15393 bool is_const = cBOOL(CvCONST(old_cv));
15394 SV *old_const_sv = is_const ? cv_const_sv_or_av(old_cv) : NULL;
15395
15396 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
15397
15398 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
15399 return;
15400 /* They are 2 constant subroutines generated from
15401 the same constant. This probably means that
15402 they are really the "same" proxy subroutine
15403 instantiated in 2 places. Most likely this is
15404 when a constant is exported twice. Don't warn.
15405 */
15406 if (
15407 (ckWARN(WARN_REDEFINE)
15408 && !(
15409 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
15410 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
15411 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
15412 strEQ(hvname, "autouse"))
15413 )
15414 )
15415 || (is_const
15416 && ckWARN_d(WARN_REDEFINE)
15417 && (!new_const_svp ||
15418 !*new_const_svp ||
15419 !old_const_sv ||
15420 SvTYPE(old_const_sv) == SVt_PVAV ||
15421 SvTYPE(*new_const_svp) == SVt_PVAV ||
15422 sv_cmp(old_const_sv, *new_const_svp))
15423 )
15424 ) {
15425 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
15426 is_const
15427 ? "Constant subroutine %" SVf " redefined"
15428 : CvIsMETHOD(old_cv)
15429 ? "Method %" SVf " redefined"
15430 : "Subroutine %" SVf " redefined",
15431 SVfARG(name));
15432 }
15433 }
15434
15435 /*
15436 =for apidoc_section $hook
15437
15438 These functions provide convenient and thread-safe means of manipulating
15439 hook variables.
15440
15441 =cut
15442 */
15443
15444 /*
15445 =for apidoc wrap_op_checker
15446
15447 Puts a C function into the chain of check functions for a specified op
15448 type. This is the preferred way to manipulate the L</PL_check> array.
15449 C<opcode> specifies which type of op is to be affected. C<new_checker>
15450 is a pointer to the C function that is to be added to that opcode's
15451 check chain, and C<old_checker_p> points to the storage location where a
15452 pointer to the next function in the chain will be stored. The value of
15453 C<new_checker> is written into the L</PL_check> array, while the value
15454 previously stored there is written to C<*old_checker_p>.
15455
15456 L</PL_check> is global to an entire process, and a module wishing to
15457 hook op checking may find itself invoked more than once per process,
15458 typically in different threads. To handle that situation, this function
15459 is idempotent. The location C<*old_checker_p> must initially (once
15460 per process) contain a null pointer. A C variable of static duration
15461 (declared at file scope, typically also marked C<static> to give
15462 it internal linkage) will be implicitly initialised appropriately,
15463 if it does not have an explicit initialiser. This function will only
15464 actually modify the check chain if it finds C<*old_checker_p> to be null.
15465 This function is also thread safe on the small scale. It uses appropriate
15466 locking to avoid race conditions in accessing L</PL_check>.
15467
15468 When this function is called, the function referenced by C<new_checker>
15469 must be ready to be called, except for C<*old_checker_p> being unfilled.
15470 In a threading situation, C<new_checker> may be called immediately,
15471 even before this function has returned. C<*old_checker_p> will always
15472 be appropriately set before C<new_checker> is called. If C<new_checker>
15473 decides not to do anything special with an op that it is given (which
15474 is the usual case for most uses of op check hooking), it must chain the
15475 check function referenced by C<*old_checker_p>.
15476
15477 Taken all together, XS code to hook an op checker should typically look
15478 something like this:
15479
15480 static Perl_check_t nxck_frob;
15481 static OP *myck_frob(pTHX_ OP *op) {
15482 ...
15483 op = nxck_frob(aTHX_ op);
15484 ...
15485 return op;
15486 }
15487 BOOT:
15488 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
15489
15490 If you want to influence compilation of calls to a specific subroutine,
15491 then use L</cv_set_call_checker_flags> rather than hooking checking of
15492 all C<entersub> ops.
15493
15494 =cut
15495 */
15496
15497 void
Perl_wrap_op_checker(pTHX_ Optype opcode,Perl_check_t new_checker,Perl_check_t * old_checker_p)15498 Perl_wrap_op_checker(pTHX_ Optype opcode,
15499 Perl_check_t new_checker, Perl_check_t *old_checker_p)
15500 {
15501
15502 PERL_UNUSED_CONTEXT;
15503 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
15504 if (*old_checker_p) return;
15505 OP_CHECK_MUTEX_LOCK;
15506 if (!*old_checker_p) {
15507 *old_checker_p = PL_check[opcode];
15508 PL_check[opcode] = new_checker;
15509 }
15510 OP_CHECK_MUTEX_UNLOCK;
15511 }
15512
15513 #include "XSUB.h"
15514
15515 /* Efficient sub that returns a constant scalar value. */
15516 static void
const_sv_xsub(pTHX_ CV * cv)15517 const_sv_xsub(pTHX_ CV* cv)
15518 {
15519 dXSARGS;
15520 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
15521 PERL_UNUSED_ARG(items);
15522 if (!sv) {
15523 XSRETURN(0);
15524 }
15525 EXTEND(sp, 1);
15526 ST(0) = sv;
15527 XSRETURN(1);
15528 }
15529
15530 static void
const_av_xsub(pTHX_ CV * cv)15531 const_av_xsub(pTHX_ CV* cv)
15532 {
15533 dXSARGS;
15534 AV * const av = MUTABLE_AV(XSANY.any_ptr);
15535 SP -= items;
15536 assert(av);
15537 #ifndef DEBUGGING
15538 if (!av) {
15539 XSRETURN(0);
15540 }
15541 #endif
15542 if (SvRMAGICAL(av))
15543 Perl_croak(aTHX_ "Magical list constants are not supported");
15544 if (GIMME_V != G_LIST) {
15545 EXTEND(SP, 1);
15546 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15547 XSRETURN(1);
15548 }
15549 EXTEND(SP, AvFILLp(av)+1);
15550 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15551 XSRETURN(AvFILLp(av)+1);
15552 }
15553
15554 /* Copy an existing cop->cop_warnings field.
15555 * If it's one of the standard addresses, just re-use the address.
15556 * This is the e implementation for the DUP_WARNINGS() macro
15557 */
15558
15559 char *
Perl_dup_warnings(pTHX_ char * warnings)15560 Perl_dup_warnings(pTHX_ char* warnings)
15561 {
15562 if (warnings == NULL || specialWARN(warnings))
15563 return warnings;
15564
15565 return rcpv_copy(warnings);
15566 }
15567
15568 /*
15569 =for apidoc rcpv_new
15570
15571 Create a new shared memory refcounted string with the requested size, and
15572 with the requested initialization and a refcount of 1. The actual space
15573 allocated will be 1 byte more than requested and rcpv_new() will ensure that
15574 the extra byte is a null regardless of any flags settings.
15575
15576 If the RCPVf_NO_COPY flag is set then the pv argument will be
15577 ignored, otherwise the contents of the pv pointer will be copied into
15578 the new buffer or if it is NULL the function will do nothing and return NULL.
15579
15580 If the RCPVf_USE_STRLEN flag is set then the len argument is ignored and
15581 recomputed using C<strlen(pv)>. It is an error to combine RCPVf_USE_STRLEN
15582 and RCPVf_NO_COPY at the same time.
15583
15584 Under DEBUGGING rcpv_new() will assert() if it is asked to create a 0 length
15585 shared string unless the RCPVf_ALLOW_EMPTY flag is set.
15586
15587 The return value from the function is suitable for passing into rcpv_copy() and
15588 rcpv_free(). To access the RCPV * from the returned value use the RCPVx() macro.
15589 The 'len' member of the RCPV struct stores the allocated length (including the
15590 extra byte), but the RCPV_LEN() macro returns the requested length (not
15591 including the extra byte).
15592
15593 Note that rcpv_new() does NOT use a hash table or anything like that to
15594 dedupe inputs given the same text content. Each call with a non-null pv
15595 parameter will produce a distinct pointer with its own refcount regardless of
15596 the input content.
15597
15598 =cut
15599 */
15600
15601 char *
Perl_rcpv_new(pTHX_ const char * pv,STRLEN len,U32 flags)15602 Perl_rcpv_new(pTHX_ const char *pv, STRLEN len, U32 flags) {
15603 RCPV *rcpv;
15604
15605 PERL_ARGS_ASSERT_RCPV_NEW;
15606
15607 PERL_UNUSED_CONTEXT;
15608
15609 /* Musn't use both at the same time */
15610 assert((flags & (RCPVf_NO_COPY|RCPVf_USE_STRLEN))!=
15611 (RCPVf_NO_COPY|RCPVf_USE_STRLEN));
15612
15613 if (!pv && (flags & RCPVf_NO_COPY) == 0)
15614 return NULL;
15615
15616 if (flags & RCPVf_USE_STRLEN)
15617 len = strlen(pv);
15618
15619 assert(len || (flags & RCPVf_ALLOW_EMPTY));
15620
15621 len++; /* add one for the null we will add to the end */
15622
15623 rcpv = (RCPV *)PerlMemShared_malloc(sizeof(struct rcpv) + len);
15624 if (!rcpv)
15625 croak_no_mem();
15626
15627 rcpv->len = len; /* store length including null,
15628 RCPV_LEN() subtracts 1 to account for this */
15629 rcpv->refcount = 1;
15630
15631 if ((flags & RCPVf_NO_COPY) == 0) {
15632 (void)memcpy(rcpv->pv, pv, len-1);
15633 }
15634 rcpv->pv[len-1]= '\0'; /* the last byte should always be null */
15635 return rcpv->pv;
15636 }
15637
15638 /*
15639 =for apidoc rcpv_free
15640
15641 refcount decrement a shared memory refcounted string, and when
15642 the refcount goes to 0 free it using perlmemshared_free().
15643
15644 it is the callers responsibility to ensure that the pv is the
15645 result of a rcpv_new() call.
15646
15647 Always returns NULL so it can be used like this:
15648
15649 thing = rcpv_free(thing);
15650
15651 =cut
15652 */
15653
15654 char *
Perl_rcpv_free(pTHX_ char * pv)15655 Perl_rcpv_free(pTHX_ char *pv) {
15656
15657 PERL_ARGS_ASSERT_RCPV_FREE;
15658
15659 PERL_UNUSED_CONTEXT;
15660
15661 if (!pv)
15662 return NULL;
15663 RCPV *rcpv = RCPVx(pv);
15664
15665 assert(rcpv->refcount);
15666 assert(rcpv->len);
15667
15668 OP_REFCNT_LOCK;
15669 if (--rcpv->refcount == 0) {
15670 rcpv->len = 0;
15671 PerlMemShared_free(rcpv);
15672 }
15673 OP_REFCNT_UNLOCK;
15674 return NULL;
15675 }
15676
15677 /*
15678 =for apidoc rcpv_copy
15679
15680 refcount increment a shared memory refcounted string, and when
15681 the refcount goes to 0 free it using PerlMemShared_free().
15682
15683 It is the callers responsibility to ensure that the pv is the
15684 result of a rcpv_new() call.
15685
15686 Returns the same pointer that was passed in.
15687
15688 new = rcpv_copy(pv);
15689
15690 =cut
15691 */
15692
15693
15694 char *
Perl_rcpv_copy(pTHX_ char * pv)15695 Perl_rcpv_copy(pTHX_ char *pv) {
15696
15697 PERL_ARGS_ASSERT_RCPV_COPY;
15698
15699 PERL_UNUSED_CONTEXT;
15700
15701 if (!pv)
15702 return NULL;
15703 RCPV *rcpv = RCPVx(pv);
15704 OP_REFCNT_LOCK;
15705 rcpv->refcount++;
15706 OP_REFCNT_UNLOCK;
15707 return pv;
15708 }
15709
15710 /*
15711 * ex: set ts=8 sts=4 sw=4 et:
15712 */
15713