This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fix perl -d’s "l" command.
[perl5.git] / op.c
CommitLineData
4b88f280 1#line 2 "op.c"
a0d0e21e 2/* op.c
79072805 3 *
1129b882
NC		 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
79072805
LW		 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 *
a0d0e21e
LW		 10 */
11
12/*
4ac71550
TC		 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"]
79072805
LW		 20 */
21
166f8a29
DM		 22/* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
24 *
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
31 * stack.
32 *
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
37 *
38 * newBINOP(OP_ADD, flags,
39 * newSVREF($a),
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41 * )
42 *
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
45 */
ccfc67b7 46
61b743bb
DM		 47/*
48Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49
50 A bottom-up pass
51 A top-down pass
52 An execution-order pass
53
54The bottom-up pass is represented by all the "newOP" routines and
55the ck_ routines. The bottom-upness is actually driven by yacc.
56So at the point that a ck_ routine fires, we have no idea what the
57context is, either upward in the syntax tree, or either forward or
58backward in the execution order. (The bottom-up parser builds that
59part of the execution order it knows about, but if you follow the "next"
60links around, you'll find it's actually a closed loop through the
ef9da979 61top level node.)
61b743bb
DM		 62
63Whenever the bottom-up parser gets to a node that supplies context to
64its components, it invokes that portion of the top-down pass that applies
65to that part of the subtree (and marks the top node as processed, so
66if a node further up supplies context, it doesn't have to take the
67plunge again). As a particular subcase of this, as the new node is
68built, it takes all the closed execution loops of its subcomponents
69and links them into a new closed loop for the higher level node. But
70it's still not the real execution order.
71
72The actual execution order is not known till we get a grammar reduction
73to a top-level unit like a subroutine or file that will be called by
74"name" rather than via a "next" pointer. At that point, we can call
75into peep() to do that code's portion of the 3rd pass. It has to be
76recursive, but it's recursive on basic blocks, not on tree nodes.
77*/
78
06e0342d 79/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC		 80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
06e0342d 87 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC		 88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
91
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
34795b44 96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
c28fe1ec
NC		 97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC		 99*/
100
79072805 101#include "EXTERN.h"
864dbfa3 102#define PERL_IN_OP_C
79072805 103#include "perl.h"
77ca0c92 104#include "keywords.h"
2846acbf 105#include "feature.h"
74529a43 106#include "regcomp.h"
79072805 107
16c91539 108#define CALL_PEEP(o) PL_peepp(aTHX_ o)
1a0a2ba9 109#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
16c91539 110#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
a2efc822 111
238a4c30
NIS		 112#if defined(PL_OP_SLAB_ALLOC)
113
f1fac472
NC		 114#ifdef PERL_DEBUG_READONLY_OPS
115# define PERL_SLAB_SIZE 4096
116# include <sys/mman.h>
117#endif
118
238a4c30
NIS		 119#ifndef PERL_SLAB_SIZE
120#define PERL_SLAB_SIZE 2048
121#endif
122
c7e45529 123void *
e91d68d5 124Perl_Slab_Alloc(pTHX_ size_t sz)
1c846c1f 125{
5186cc12 126 dVAR;
5a8e194f
NIS		 127 /*
128 * To make incrementing use count easy PL_OpSlab is an I32 *
129 * To make inserting the link to slab PL_OpPtr is I32 **
130 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
131 * Add an overhead for pointer to slab and round up as a number of pointers
132 */
133 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 134 if ((PL_OpSpace -= sz) < 0) {
f1fac472
NC		 135#ifdef PERL_DEBUG_READONLY_OPS
136 /* We need to allocate chunk by chunk so that we can control the VM
137 mapping */
5186cc12 138 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
f1fac472
NC		 139 MAP_ANON|MAP_PRIVATE, -1, 0);
140
141 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
142 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
143 PL_OpPtr));
144 if(PL_OpPtr == MAP_FAILED) {
145 perror("mmap failed");
146 abort();
147 }
148#else
277e868c
NC		 149
150 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
f1fac472 151#endif
083fcd59 152 if (!PL_OpPtr) {
238a4c30
NIS		 153 return NULL;
154 }
5a8e194f
NIS		 155 /* We reserve the 0'th I32 sized chunk as a use count */
156 PL_OpSlab = (I32 *) PL_OpPtr;
157 /* Reduce size by the use count word, and by the size we need.
158 * Latter is to mimic the '-=' in the if() above
159 */
160 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS		 161 /* Allocation pointer starts at the top.
162 Theory: because we build leaves before trunk allocating at end
163 means that at run time access is cache friendly upward
164 */
5a8e194f 165 PL_OpPtr += PERL_SLAB_SIZE;
f1fac472
NC		 166
167#ifdef PERL_DEBUG_READONLY_OPS
168 /* We remember this slab. */
169 /* This implementation isn't efficient, but it is simple. */
5186cc12 170 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
f1fac472
NC		 171 PL_slabs[PL_slab_count++] = PL_OpSlab;
172 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
173#endif
238a4c30
NIS		 174 }
175 assert( PL_OpSpace >= 0 );
176 /* Move the allocation pointer down */
177 PL_OpPtr -= sz;
5a8e194f 178 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS		 179 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
180 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 181 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS		 182 assert( *PL_OpSlab > 0 );
183 return (void *)(PL_OpPtr + 1);
184}
185
f1fac472
NC		 186#ifdef PERL_DEBUG_READONLY_OPS
187void
188Perl_pending_Slabs_to_ro(pTHX) {
189 /* Turn all the allocated op slabs read only. */
190 U32 count = PL_slab_count;
191 I32 **const slabs = PL_slabs;
192
193 /* Reset the array of pending OP slabs, as we're about to turn this lot
194 read only. Also, do it ahead of the loop in case the warn triggers,
195 and a warn handler has an eval */
196
f1fac472
NC		 197 PL_slabs = NULL;
198 PL_slab_count = 0;
199
200 /* Force a new slab for any further allocation. */
201 PL_OpSpace = 0;
202
203 while (count--) {
5892a4d4 204 void *const start = slabs[count];
f1fac472
NC		 205 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
206 if(mprotect(start, size, PROT_READ)) {
207 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
208 start, (unsigned long) size, errno);
209 }
210 }
5892a4d4
NC		 211
212 free(slabs);
f1fac472
NC		 213}
214
215STATIC void
216S_Slab_to_rw(pTHX_ void *op)
217{
218 I32 * const * const ptr = (I32 **) op;
219 I32 * const slab = ptr[-1];
7918f24d
NC		 220
221 PERL_ARGS_ASSERT_SLAB_TO_RW;
222
f1fac472
NC		 223 assert( ptr-1 > (I32 **) slab );
224 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
225 assert( *slab > 0 );
226 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
227 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
228 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
229 }
230}
fc97af9c
NC		 231
232OP *
233Perl_op_refcnt_inc(pTHX_ OP *o)
234{
235 if(o) {
236 Slab_to_rw(o);
237 ++o->op_targ;
238 }
239 return o;
240
241}
242
243PADOFFSET
244Perl_op_refcnt_dec(pTHX_ OP *o)
245{
7918f24d 246 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
fc97af9c
NC		 247 Slab_to_rw(o);
248 return --o->op_targ;
249}
f1fac472
NC		 250#else
251# define Slab_to_rw(op)
252#endif
253
c7e45529
AE		 254void
255Perl_Slab_Free(pTHX_ void *op)
238a4c30 256{
551405c4 257 I32 * const * const ptr = (I32 **) op;
aec46f14 258 I32 * const slab = ptr[-1];
7918f24d 259 PERL_ARGS_ASSERT_SLAB_FREE;
5a8e194f
NIS		 260 assert( ptr-1 > (I32 **) slab );
261 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30 262 assert( *slab > 0 );
f1fac472 263 Slab_to_rw(op);
238a4c30 264 if (--(*slab) == 0) {
7e4e8c89
NC		 265# ifdef NETWARE
266# define PerlMemShared PerlMem
267# endif
083fcd59 268
f1fac472 269#ifdef PERL_DEBUG_READONLY_OPS
782a40f1 270 U32 count = PL_slab_count;
f1fac472 271 /* Need to remove this slab from our list of slabs */
782a40f1 272 if (count) {
f1fac472
NC		 273 while (count--) {
274 if (PL_slabs[count] == slab) {
5186cc12 275 dVAR;
f1fac472
NC		 276 /* Found it. Move the entry at the end to overwrite it. */
277 DEBUG_m(PerlIO_printf(Perl_debug_log,
278 "Deallocate %p by moving %p from %lu to %lu\n",
279 PL_OpSlab,
280 PL_slabs[PL_slab_count - 1],
281 PL_slab_count, count));
282 PL_slabs[count] = PL_slabs[--PL_slab_count];
283 /* Could realloc smaller at this point, but probably not
284 worth it. */
fc97af9c
NC		 285 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
286 perror("munmap failed");
287 abort();
288 }
289 break;
f1fac472 290 }
f1fac472
NC		 291 }
292 }
293#else
083fcd59 294 PerlMemShared_free(slab);
f1fac472 295#endif
238a4c30
NIS		 296 if (slab == PL_OpSlab) {
297 PL_OpSpace = 0;
298 }
299 }
b7dc083c 300}
8be227ab
FC		 301#else /* !defined(PL_OP_SLAB_ALLOC) */
302
303/* See the explanatory comments above struct opslab in op.h. */
304
305# ifndef PERL_SLAB_SIZE
306# define PERL_SLAB_SIZE 64
307# endif
308
309/* rounds up to nearest pointer */
310# define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
311# define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
312
313static OPSLAB *
314S_new_slab(pTHX_ size_t sz)
315{
316 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
317 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
318 return slab;
319}
320
e7372881
FC		 321/* requires double parens and aTHX_ */
322#define DEBUG_S_warn(args) \
323 DEBUG_S( \
324 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
325 )
326
8be227ab
FC		 327void *
328Perl_Slab_Alloc(pTHX_ size_t sz)
329{
330 dVAR;
331 OPSLAB *slab;
332 OPSLAB *slab2;
333 OPSLOT *slot;
334 OP *o;
5cb52f30 335 size_t opsz, space;
8be227ab
FC		 336
337 if (!PL_compcv || CvROOT(PL_compcv)
338 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
339 return PerlMemShared_calloc(1, sz);
340
341 if (!CvSTART(PL_compcv)) { /* sneak it in here */
342 CvSTART(PL_compcv) =
343 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
344 CvSLABBED_on(PL_compcv);
345 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
346 }
347 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
348
5cb52f30
FC		 349 opsz = SIZE_TO_PSIZE(sz);
350 sz = opsz + OPSLOT_HEADER_P;
8be227ab
FC		 351
352 if (slab->opslab_freed) {
353 OP **too = &slab->opslab_freed;
354 o = *too;
e7372881 355 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
8be227ab 356 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
e7372881 357 DEBUG_S_warn((aTHX_ "Alas! too small"));
8be227ab 358 o = *(too = &o->op_next);
94b67eb2 359 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
8be227ab
FC		 360 }
361 if (o) {
362 *too = o->op_next;
5cb52f30 363 Zero(o, opsz, I32 *);
8be227ab
FC		 364 o->op_slabbed = 1;
365 return (void *)o;
366 }
367 }
368
369# define INIT_OPSLOT \
370 slot->opslot_slab = slab; \
371 slot->opslot_next = slab2->opslab_first; \
372 slab2->opslab_first = slot; \
373 o = &slot->opslot_op; \
374 o->op_slabbed = 1
375
376 /* The partially-filled slab is next in the chain. */
377 slab2 = slab->opslab_next ? slab->opslab_next : slab;
378 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
379 /* Remaining space is too small. */
380
8be227ab
FC		 381 /* If we can fit a BASEOP, add it to the free chain, so as not
382 to waste it. */
383 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
384 slot = &slab2->opslab_slots;
385 INIT_OPSLOT;
386 o->op_type = OP_FREED;
387 o->op_next = slab->opslab_freed;
388 slab->opslab_freed = o;
389 }
390
391 /* Create a new slab. Make this one twice as big. */
392 slot = slab2->opslab_first;
393 while (slot->opslot_next) slot = slot->opslot_next;
9963ffa2
FC		 394 slab2 = S_new_slab(aTHX_ DIFF(slab2, slot)*2);
395 slab2->opslab_next = slab->opslab_next;
396 slab->opslab_next = slab2;
8be227ab
FC		 397 }
398 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
399
400 /* Create a new op slot */
401 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
402 assert(slot >= &slab2->opslab_slots);
51c777ca
FC		 403 if (DIFF(&slab2->opslab_slots, slot)
404 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
405 slot = &slab2->opslab_slots;
8be227ab 406 INIT_OPSLOT;
e7372881 407 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
8be227ab
FC		 408 return (void *)o;
409}
410
411# undef INIT_OPSLOT
412
413/* This cannot possibly be right, but it was copied from the old slab
414 allocator, to which it was originally added, without explanation, in
415 commit 083fcd5. */
416# ifdef NETWARE
417# define PerlMemShared PerlMem
418# endif
419
420void
421Perl_Slab_Free(pTHX_ void *op)
422{
20429ba0 423 dVAR;
8be227ab
FC		 424 OP * const o = (OP *)op;
425 OPSLAB *slab;
426
427 PERL_ARGS_ASSERT_SLAB_FREE;
428
429 if (!o->op_slabbed) {
430 PerlMemShared_free(op);
431 return;
432 }
433
434 slab = OpSLAB(o);
435 /* If this op is already freed, our refcount will get screwy. */
436 assert(o->op_type != OP_FREED);
437 o->op_type = OP_FREED;
438 o->op_next = slab->opslab_freed;
439 slab->opslab_freed = o;
e7372881 440 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
8be227ab
FC		 441 OpslabREFCNT_dec_padok(slab);
442}
443
444void
445Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
446{
447 dVAR;
448 const bool havepad = !!PL_comppad;
449 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
450 if (havepad) {
451 ENTER;
452 PAD_SAVE_SETNULLPAD();
453 }
454 opslab_free(slab);
455 if (havepad) LEAVE;
456}
457
458void
459Perl_opslab_free(pTHX_ OPSLAB *slab)
460{
20429ba0 461 dVAR;
8be227ab
FC		 462 OPSLAB *slab2;
463 PERL_ARGS_ASSERT_OPSLAB_FREE;
e7372881 464 DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
8be227ab
FC		 465 assert(slab->opslab_refcnt == 1);
466 for (; slab; slab = slab2) {
467 slab2 = slab->opslab_next;
468# ifdef DEBUGGING
469 slab->opslab_refcnt = ~(size_t)0;
470# endif
471 PerlMemShared_free(slab);
472 }
473}
474
475void
476Perl_opslab_force_free(pTHX_ OPSLAB *slab)
477{
478 OPSLAB *slab2;
479 OPSLOT *slot;
480# ifdef DEBUGGING
481 size_t savestack_count = 0;
482# endif
483 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
484 slab2 = slab;
485 do {
486 for (slot = slab2->opslab_first;
487 slot->opslot_next;
488 slot = slot->opslot_next) {
489 if (slot->opslot_op.op_type != OP_FREED
490 && !(slot->opslot_op.op_savefree
491# ifdef DEBUGGING
492 && ++savestack_count
493# endif
494 )
495 ) {
496 assert(slot->opslot_op.op_slabbed);
497 slab->opslab_refcnt++; /* op_free may free slab */
498 op_free(&slot->opslot_op);
499 if (!--slab->opslab_refcnt) goto free;
500 }
501 }
502 } while ((slab2 = slab2->opslab_next));
503 /* > 1 because the CV still holds a reference count. */
504 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
505# ifdef DEBUGGING
506 assert(savestack_count == slab->opslab_refcnt-1);
507# endif
508 return;
509 }
510 free:
511 opslab_free(slab);
512}
513
b7dc083c 514#endif
e50aee73 515/*
ce6f1cbc 516 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 517 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 518 */
11343788 519#define CHECKOP(type,o) \
ce6f1cbc 520 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 521 ? ( op_free((OP*)o), \
cb77fdf0 522 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 523 (OP*)0 ) \
16c91539 524 : PL_check[type](aTHX_ (OP*)o))
e50aee73 525
e6438c1a 526#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 527
cba5a3b0
DG		 528#define CHANGE_TYPE(o,type) \
529 STMT_START { \
530 o->op_type = (OPCODE)type; \
531 o->op_ppaddr = PL_ppaddr[type]; \
532 } STMT_END
533
ce16c625 534STATIC SV*
cea2e8a9 535S_gv_ename(pTHX_ GV *gv)
4633a7c4 536{
46c461b5 537 SV* const tmpsv = sv_newmortal();
7918f24d
NC		 538
539 PERL_ARGS_ASSERT_GV_ENAME;
540
bd61b366 541 gv_efullname3(tmpsv, gv, NULL);
ce16c625 542 return tmpsv;
4633a7c4
LW		 543}
544
76e3520e 545STATIC OP *
cea2e8a9 546S_no_fh_allowed(pTHX_ OP *o)
79072805 547{
7918f24d
NC		 548 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
549
cea2e8a9 550 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 551 OP_DESC(o)));
11343788 552 return o;
79072805
LW		 553}
554
76e3520e 555STATIC OP *
ce16c625 556S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
79072805 557{
ce16c625
BF		 558 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
559 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
560 SvUTF8(namesv) | flags);
561 return o;
562}
563
564STATIC OP *
565S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
566{
567 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
568 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
569 return o;
570}
571
572STATIC OP *
573S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
574{
575 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
7918f24d 576
ce16c625 577 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
11343788 578 return o;
79072805
LW		 579}
580
76e3520e 581STATIC OP *
ce16c625 582S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
79072805 583{
ce16c625 584 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
7918f24d 585
ce16c625
BF		 586 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
587 SvUTF8(namesv) | flags);
11343788 588 return o;
79072805
LW		 589}
590
76e3520e 591STATIC void
ce16c625 592S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
8990e307 593{
ce16c625
BF		 594 PERL_ARGS_ASSERT_BAD_TYPE_PV;
595
596 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
597 (int)n, name, t, OP_DESC(kid)), flags);
598}
7918f24d 599
ce16c625
BF		 600STATIC void
601S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
602{
603 PERL_ARGS_ASSERT_BAD_TYPE_SV;
604
605 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
606 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
8990e307
LW		 607}
608
7a52d87a 609STATIC void
eb796c7f 610S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 611{
7918f24d
NC		 612 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
613
eb8433b7
NC		 614 if (PL_madskills)
615 return; /* various ok barewords are hidden in extra OP_NULL */
5a844595 616 qerror(Perl_mess(aTHX_
35c1215d 617 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
be2597df 618 SVfARG(cSVOPo_sv)));
eb796c7f 619 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
7a52d87a
GS		 620}
621
79072805
LW		 622/* "register" allocation */
623
624PADOFFSET
d6447115 625Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
93a17b20 626{
97aff369 627 dVAR;
a0d0e21e 628 PADOFFSET off;
12bd6ede 629 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 630
7918f24d
NC		 631 PERL_ARGS_ASSERT_ALLOCMY;
632
48d0d1be 633 if (flags & ~SVf_UTF8)
d6447115
NC		 634 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
635 (UV)flags);
636
637 /* Until we're using the length for real, cross check that we're being
638 told the truth. */
639 assert(strlen(name) == len);
640
59f00321 641 /* complain about "my $<special_var>" etc etc */
d6447115 642 if (len &&
3edf23ff 643 !(is_our ||
155aba94 644 isALPHA(name[1]) ||
b14845b4 645 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
d6447115 646 (name[1] == '_' && (*name == '$' || len > 2))))
834a4ddd 647 {
6b58708b 648 /* name[2] is true if strlen(name) > 2 */
b14845b4
FC		 649 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
650 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
d6447115
NC		 651 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
652 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
aab6a793 653 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 654 } else {
ce16c625
BF		 655 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
656 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
46fc3d4c 657 }
a0d0e21e 658 }
748a9306 659
dd2155a4 660 /* allocate a spare slot and store the name in that slot */
93a17b20 661
cc76b5cc 662 off = pad_add_name_pvn(name, len,
48d0d1be
BF		 663 (is_our ? padadd_OUR :
664 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
665 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
12bd6ede 666 PL_parser->in_my_stash,
3edf23ff 667 (is_our
133706a6
RGS		 668 /* $_ is always in main::, even with our */
669 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 670 : NULL
cca43f78 671 )
dd2155a4 672 );
a74073ad
DM		 673 /* anon sub prototypes contains state vars should always be cloned,
674 * otherwise the state var would be shared between anon subs */
675
676 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
677 CvCLONE_on(PL_compcv);
678
dd2155a4 679 return off;
79072805
LW		 680}
681
c0b8aebd
FC		 682/*
683=for apidoc alloccopstash
684
685Available only under threaded builds, this function allocates an entry in
686C<PL_stashpad> for the stash passed to it.
687
688=cut
689*/
690
d4d03940
FC		 691#ifdef USE_ITHREADS
692PADOFFSET
693Perl_alloccopstash(pTHX_ HV *hv)
694{
695 PADOFFSET off = 0, o = 1;
696 bool found_slot = FALSE;
697
698 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
699
700 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
701
702 for (; o < PL_stashpadmax; ++o) {
703 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
704 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
705 found_slot = TRUE, off = o;
706 }
707 if (!found_slot) {
708 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
709 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
710 off = PL_stashpadmax;
711 PL_stashpadmax += 10;
712 }
713
714 PL_stashpad[PL_stashpadix = off] = hv;
715 return off;
716}
717#endif
718
d2c837a0
DM		 719/* free the body of an op without examining its contents.
720 * Always use this rather than FreeOp directly */
721
4136a0f7 722static void
d2c837a0
DM		 723S_op_destroy(pTHX_ OP *o)
724{
725 if (o->op_latefree) {
726 o->op_latefreed = 1;
727 return;
728 }
729 FreeOp(o);
730}
731
c4bd3ae5
NC		 732#ifdef USE_ITHREADS
733# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
734#else
735# define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
736#endif
d2c837a0 737
79072805
LW		 738/* Destructor */
739
740void
864dbfa3 741Perl_op_free(pTHX_ OP *o)
79072805 742{
27da23d5 743 dVAR;
acb36ea4 744 OPCODE type;
79072805 745
8be227ab
FC		 746#ifndef PL_OP_SLAB_ALLOC
747 /* Though ops may be freed twice, freeing the op after its slab is a
748 big no-no. */
749 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
750#endif
751 /* During the forced freeing of ops after compilation failure, kidops
752 may be freed before their parents. */
753 if (!o || o->op_type == OP_FREED)
79072805 754 return;
670f3923
DM		 755 if (o->op_latefreed) {
756 if (o->op_latefree)
757 return;
758 goto do_free;
759 }
79072805 760
67566ccd 761 type = o->op_type;
7934575e 762 if (o->op_private & OPpREFCOUNTED) {
67566ccd 763 switch (type) {
7934575e
GS		 764 case OP_LEAVESUB:
765 case OP_LEAVESUBLV:
766 case OP_LEAVEEVAL:
767 case OP_LEAVE:
768 case OP_SCOPE:
769 case OP_LEAVEWRITE:
67566ccd
AL		 770 {
771 PADOFFSET refcnt;
7934575e 772 OP_REFCNT_LOCK;
4026c95a 773 refcnt = OpREFCNT_dec(o);
7934575e 774 OP_REFCNT_UNLOCK;
bfd0ff22
NC		 775 if (refcnt) {
776 /* Need to find and remove any pattern match ops from the list
777 we maintain for reset(). */
778 find_and_forget_pmops(o);
4026c95a 779 return;
67566ccd 780 }
bfd0ff22 781 }
7934575e
GS		 782 break;
783 default:
784 break;
785 }
786 }
787
f37b8c3f
VP		 788 /* Call the op_free hook if it has been set. Do it now so that it's called
789 * at the right time for refcounted ops, but still before all of the kids
790 * are freed. */
791 CALL_OPFREEHOOK(o);
792
11343788 793 if (o->op_flags & OPf_KIDS) {
6867be6d 794 register OP *kid, *nextkid;
11343788 795 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 796 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 797 op_free(kid);
85e6fe83 798 }
79072805 799 }
acb36ea4 800
fc97af9c
NC		 801#ifdef PERL_DEBUG_READONLY_OPS
802 Slab_to_rw(o);
803#endif
804
acb36ea4
GS		 805 /* COP* is not cleared by op_clear() so that we may track line
806 * numbers etc even after null() */
cc93af5f
RGS		 807 if (type == OP_NEXTSTATE || type == OP_DBSTATE
808 || (type == OP_NULL /* the COP might have been null'ed */
809 && ((OPCODE)o->op_targ == OP_NEXTSTATE
810 || (OPCODE)o->op_targ == OP_DBSTATE))) {
acb36ea4 811 cop_free((COP*)o);
3235b7a3 812 }
acb36ea4 813
c53f1caa
RU		 814 if (type == OP_NULL)
815 type = (OPCODE)o->op_targ;
816
acb36ea4 817 op_clear(o);
670f3923
DM		 818 if (o->op_latefree) {
819 o->op_latefreed = 1;
820 return;
821 }
822 do_free:
238a4c30 823 FreeOp(o);
4d494880
DM		 824#ifdef DEBUG_LEAKING_SCALARS
825 if (PL_op == o)
5f66b61c 826 PL_op = NULL;
4d494880 827#endif
acb36ea4 828}
79072805 829
93c66552
DM		 830void
831Perl_op_clear(pTHX_ OP *o)
acb36ea4 832{
13137afc 833
27da23d5 834 dVAR;
7918f24d
NC		 835
836 PERL_ARGS_ASSERT_OP_CLEAR;
837
eb8433b7 838#ifdef PERL_MAD
df31c78c
NC		 839 mad_free(o->op_madprop);
840 o->op_madprop = 0;
eb8433b7
NC		 841#endif
842
843 retry:
11343788 844 switch (o->op_type) {
acb36ea4 845 case OP_NULL: /* Was holding old type, if any. */
eb8433b7 846 if (PL_madskills && o->op_targ != OP_NULL) {
61a59f30 847 o->op_type = (Optype)o->op_targ;
eb8433b7
NC		 848 o->op_targ = 0;
849 goto retry;
850 }
4d193d44 851 case OP_ENTERTRY:
acb36ea4 852 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 853 o->op_targ = 0;
a0d0e21e 854 break;
a6006777 855 default:
ac4c12e7 856 if (!(o->op_flags & OPf_REF)
ef69c8fc 857 || (PL_check[o->op_type] != Perl_ck_ftst))
a6006777 858 break;
859 /* FALL THROUGH */
463ee0b2 860 case OP_GVSV:
79072805 861 case OP_GV:
a6006777 862 case OP_AELEMFAST:
93bad3fd 863 {
f7461760
Z		 864 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
865#ifdef USE_ITHREADS
866 && PL_curpad
867#endif
868 ? cGVOPo_gv : NULL;
b327b36f
NC		 869 /* It's possible during global destruction that the GV is freed
870 before the optree. Whilst the SvREFCNT_inc is happy to bump from
871 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
872 will trigger an assertion failure, because the entry to sv_clear
873 checks that the scalar is not already freed. A check of for
874 !SvIS_FREED(gv) turns out to be invalid, because during global
875 destruction the reference count can be forced down to zero
876 (with SVf_BREAK set). In which case raising to 1 and then
877 dropping to 0 triggers cleanup before it should happen. I
878 *think* that this might actually be a general, systematic,
879 weakness of the whole idea of SVf_BREAK, in that code *is*
880 allowed to raise and lower references during global destruction,
881 so any *valid* code that happens to do this during global
882 destruction might well trigger premature cleanup. */
883 bool still_valid = gv && SvREFCNT(gv);
884
885 if (still_valid)
886 SvREFCNT_inc_simple_void(gv);
350de78d 887#ifdef USE_ITHREADS
6a077020
DM		 888 if (cPADOPo->op_padix > 0) {
889 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
890 * may still exist on the pad */
891 pad_swipe(cPADOPo->op_padix, TRUE);
892 cPADOPo->op_padix = 0;
893 }
350de78d 894#else
6a077020 895 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 896 cSVOPo->op_sv = NULL;
350de78d 897#endif
b327b36f 898 if (still_valid) {
f7461760
Z		 899 int try_downgrade = SvREFCNT(gv) == 2;
900 SvREFCNT_dec(gv);
901 if (try_downgrade)
902 gv_try_downgrade(gv);
903 }
6a077020 904 }
79072805 905 break;
a1ae71d2 906 case OP_METHOD_NAMED:
79072805 907 case OP_CONST:
996c9baa 908 case OP_HINTSEVAL:
11343788 909 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 910 cSVOPo->op_sv = NULL;
3b1c21fa
AB		 911#ifdef USE_ITHREADS
912 /** Bug #15654
913 Even if op_clear does a pad_free for the target of the op,
6a077020 914 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 915 instead it lives on. This results in that it could be reused as
916 a target later on when the pad was reallocated.
917 **/
918 if(o->op_targ) {
919 pad_swipe(o->op_targ,1);
920 o->op_targ = 0;
921 }
922#endif
79072805 923 break;
748a9306
LW		 924 case OP_GOTO:
925 case OP_NEXT:
926 case OP_LAST:
927 case OP_REDO:
11343788 928 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 929 break;
930 /* FALL THROUGH */
a0d0e21e 931 case OP_TRANS:
bb16bae8 932 case OP_TRANSR:
acb36ea4 933 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
043e41b8
DM		 934#ifdef USE_ITHREADS
935 if (cPADOPo->op_padix > 0) {
936 pad_swipe(cPADOPo->op_padix, TRUE);
937 cPADOPo->op_padix = 0;
938 }
939#else
a0ed51b3 940 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 941 cSVOPo->op_sv = NULL;
043e41b8 942#endif
acb36ea4
GS		 943 }
944 else {
ea71c68d 945 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 946 cPVOPo->op_pv = NULL;
acb36ea4 947 }
a0d0e21e
LW		 948 break;
949 case OP_SUBST:
20e98b0f 950 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 951 goto clear_pmop;
748a9306 952 case OP_PUSHRE:
971a9dd3 953#ifdef USE_ITHREADS
20e98b0f 954 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
dd2155a4
DM		 955 /* No GvIN_PAD_off here, because other references may still
956 * exist on the pad */
20e98b0f 957 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3
GS		 958 }
959#else
ad64d0ec 960 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
971a9dd3
GS		 961#endif
962 /* FALL THROUGH */
a0d0e21e 963 case OP_MATCH:
8782bef2 964 case OP_QR:
971a9dd3 965clear_pmop:
867940b8
DM		 966 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
967 op_free(cPMOPo->op_code_list);
68e2671b 968 cPMOPo->op_code_list = NULL;
c2b1997a 969 forget_pmop(cPMOPo, 1);
20e98b0f 970 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
9cddf794
NC		 971 /* we use the same protection as the "SAFE" version of the PM_ macros
972 * here since sv_clean_all might release some PMOPs
5f8cb046
DM		 973 * after PL_regex_padav has been cleared
974 * and the clearing of PL_regex_padav needs to
975 * happen before sv_clean_all
976 */
13137afc
AB		 977#ifdef USE_ITHREADS
978 if(PL_regex_pad) { /* We could be in destruction */
402d2eb1 979 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 980 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC		 981 PL_regex_pad[offset] = &PL_sv_undef;
982 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
983 sizeof(offset));
13137afc 984 }
9cddf794
NC		 985#else
986 ReREFCNT_dec(PM_GETRE(cPMOPo));
987 PM_SETRE(cPMOPo, NULL);
1eb1540c 988#endif
13137afc 989
a0d0e21e 990 break;
79072805
LW		 991 }
992
743e66e6 993 if (o->op_targ > 0) {
11343788 994 pad_free(o->op_targ);
743e66e6
GS		 995 o->op_targ = 0;
996 }
79072805
LW		 997}
998
76e3520e 999STATIC void
3eb57f73
HS		 1000S_cop_free(pTHX_ COP* cop)
1001{
7918f24d
NC		 1002 PERL_ARGS_ASSERT_COP_FREE;
1003
05ec9bb3 1004 CopFILE_free(cop);
0453d815 1005 if (! specialWARN(cop->cop_warnings))
72dc9ed5 1006 PerlMemShared_free(cop->cop_warnings);
20439bc7 1007 cophh_free(CopHINTHASH_get(cop));
3eb57f73
HS		 1008}
1009
c2b1997a 1010STATIC void
c4bd3ae5
NC		 1011S_forget_pmop(pTHX_ PMOP *const o
1012#ifdef USE_ITHREADS
1013 , U32 flags
1014#endif
1015 )
c2b1997a
NC		 1016{
1017 HV * const pmstash = PmopSTASH(o);
7918f24d
NC		 1018
1019 PERL_ARGS_ASSERT_FORGET_PMOP;
1020
e39a6381 1021 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
ad64d0ec 1022 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC		 1023 if (mg) {
1024 PMOP **const array = (PMOP**) mg->mg_ptr;
1025 U32 count = mg->mg_len / sizeof(PMOP**);
1026 U32 i = count;
1027
1028 while (i--) {
1029 if (array[i] == o) {
1030 /* Found it. Move the entry at the end to overwrite it. */
1031 array[i] = array[--count];
1032 mg->mg_len = count * sizeof(PMOP**);
1033 /* Could realloc smaller at this point always, but probably
1034 not worth it. Probably worth free()ing if we're the
1035 last. */
1036 if(!count) {
1037 Safefree(mg->mg_ptr);
1038 mg->mg_ptr = NULL;
1039 }
1040 break;
1041 }
1042 }
1043 }
1044 }
1cdf7faf
NC		 1045 if (PL_curpm == o)
1046 PL_curpm = NULL;
c4bd3ae5 1047#ifdef USE_ITHREADS
c2b1997a
NC		 1048 if (flags)
1049 PmopSTASH_free(o);
c4bd3ae5 1050#endif
c2b1997a
NC		 1051}
1052
bfd0ff22
NC		 1053STATIC void
1054S_find_and_forget_pmops(pTHX_ OP *o)
1055{
7918f24d
NC		 1056 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1057
bfd0ff22
NC		 1058 if (o->op_flags & OPf_KIDS) {
1059 OP *kid = cUNOPo->op_first;
1060 while (kid) {
1061 switch (kid->op_type) {
1062 case OP_SUBST:
1063 case OP_PUSHRE:
1064 case OP_MATCH:
1065 case OP_QR:
1066 forget_pmop((PMOP*)kid, 0);
1067 }
1068 find_and_forget_pmops(kid);
1069 kid = kid->op_sibling;
1070 }
1071 }
1072}
1073
93c66552
DM		 1074void
1075Perl_op_null(pTHX_ OP *o)
8990e307 1076{
27da23d5 1077 dVAR;
7918f24d
NC		 1078
1079 PERL_ARGS_ASSERT_OP_NULL;
1080
acb36ea4
GS		 1081 if (o->op_type == OP_NULL)
1082 return;
eb8433b7
NC		 1083 if (!PL_madskills)
1084 op_clear(o);
11343788
MB		 1085 o->op_targ = o->op_type;
1086 o->op_type = OP_NULL;
22c35a8c 1087 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 1088}
1089
4026c95a
SH		 1090void
1091Perl_op_refcnt_lock(pTHX)
1092{
27da23d5 1093 dVAR;
96a5add6 1094 PERL_UNUSED_CONTEXT;
4026c95a
SH		 1095 OP_REFCNT_LOCK;
1096}
1097
1098void
1099Perl_op_refcnt_unlock(pTHX)
1100{
27da23d5 1101 dVAR;
96a5add6 1102 PERL_UNUSED_CONTEXT;
4026c95a
SH		 1103 OP_REFCNT_UNLOCK;
1104}
1105
79072805
LW		 1106/* Contextualizers */
1107
d9088386
Z		 1108/*
1109=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1110
1111Applies a syntactic context to an op tree representing an expression.
1112I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1113or C<G_VOID> to specify the context to apply. The modified op tree
1114is returned.
1115
1116=cut
1117*/
1118
1119OP *
1120Perl_op_contextualize(pTHX_ OP *o, I32 context)
1121{
1122 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1123 switch (context) {
1124 case G_SCALAR: return scalar(o);
1125 case G_ARRAY: return list(o);
1126 case G_VOID: return scalarvoid(o);
1127 default:
5637ef5b
NC		 1128 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1129 (long) context);
d9088386
Z		 1130 return o;
1131 }
1132}
1133
5983a79d
BM		 1134/*
1135=head1 Optree Manipulation Functions
79072805 1136
5983a79d
BM		 1137=for apidoc Am|OP*|op_linklist|OP *o
1138This function is the implementation of the L</LINKLIST> macro. It should
1139not be called directly.
1140
1141=cut
1142*/
1143
1144OP *
1145Perl_op_linklist(pTHX_ OP *o)
79072805 1146{
3edf23ff 1147 OP *first;
79072805 1148
5983a79d 1149 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 1150
11343788
MB		 1151 if (o->op_next)
1152 return o->op_next;
79072805
LW		 1153
1154 /* establish postfix order */
3edf23ff
AL		 1155 first = cUNOPo->op_first;
1156 if (first) {
6867be6d 1157 register OP *kid;
3edf23ff
AL		 1158 o->op_next = LINKLIST(first);
1159 kid = first;
1160 for (;;) {
1161 if (kid->op_sibling) {
79072805 1162 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL		 1163 kid = kid->op_sibling;
1164 } else {
11343788 1165 kid->op_next = o;
3edf23ff
AL		 1166 break;
1167 }
79072805
LW		 1168 }
1169 }
1170 else
11343788 1171 o->op_next = o;
79072805 1172
11343788 1173 return o->op_next;
79072805
LW		 1174}
1175
1f676739 1176static OP *
2dd5337b 1177S_scalarkids(pTHX_ OP *o)
79072805 1178{
11343788 1179 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 1180 OP *kid;
11343788 1181 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1182 scalar(kid);
1183 }
11343788 1184 return o;
79072805
LW		 1185}
1186
76e3520e 1187STATIC OP *
cea2e8a9 1188S_scalarboolean(pTHX_ OP *o)
8990e307 1189{
97aff369 1190 dVAR;
7918f24d
NC		 1191
1192 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1193
6b7c6d95
FC		 1194 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1195 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
d008e5eb 1196 if (ckWARN(WARN_SYNTAX)) {
6867be6d 1197 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1198
53a7735b
DM		 1199 if (PL_parser && PL_parser->copline != NOLINE)
1200 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 1201 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1202 CopLINE_set(PL_curcop, oldline);
d008e5eb 1203 }
a0d0e21e 1204 }
11343788 1205 return scalar(o);
8990e307
LW		 1206}
1207
1208OP *
864dbfa3 1209Perl_scalar(pTHX_ OP *o)
79072805 1210{
27da23d5 1211 dVAR;
79072805
LW		 1212 OP *kid;
1213
a0d0e21e 1214 /* assumes no premature commitment */
13765c85
DM		 1215 if (!o || (PL_parser && PL_parser->error_count)
1216 || (o->op_flags & OPf_WANT)
5dc0d613 1217 || o->op_type == OP_RETURN)
7e363e51 1218 {
11343788 1219 return o;
7e363e51 1220 }
79072805 1221
5dc0d613 1222 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 1223
11343788 1224 switch (o->op_type) {
79072805 1225 case OP_REPEAT:
11343788 1226 scalar(cBINOPo->op_first);
8990e307 1227 break;
79072805
LW		 1228 case OP_OR:
1229 case OP_AND:
1230 case OP_COND_EXPR:
11343788 1231 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 1232 scalar(kid);
79072805 1233 break;
a0d0e21e 1234 /* FALL THROUGH */
a6d8037e 1235 case OP_SPLIT:
79072805 1236 case OP_MATCH:
8782bef2 1237 case OP_QR:
79072805
LW		 1238 case OP_SUBST:
1239 case OP_NULL:
8990e307 1240 default:
11343788
MB		 1241 if (o->op_flags & OPf_KIDS) {
1242 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 1243 scalar(kid);
1244 }
79072805
LW		 1245 break;
1246 case OP_LEAVE:
1247 case OP_LEAVETRY:
5dc0d613 1248 kid = cLISTOPo->op_first;
54310121 1249 scalar(kid);
25b991bf
VP		 1250 kid = kid->op_sibling;
1251 do_kids:
1252 while (kid) {
1253 OP *sib = kid->op_sibling;
c08f093b
VP		 1254 if (sib && kid->op_type != OP_LEAVEWHEN)
1255 scalarvoid(kid);
1256 else
54310121 1257 scalar(kid);
25b991bf 1258 kid = sib;
54310121 1259 }
11206fdd 1260 PL_curcop = &PL_compiling;
54310121 1261 break;
748a9306 1262 case OP_SCOPE:
79072805 1263 case OP_LINESEQ:
8990e307 1264 case OP_LIST:
25b991bf
VP		 1265 kid = cLISTOPo->op_first;
1266 goto do_kids;
a801c63c 1267 case OP_SORT:
a2a5de95 1268 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553e7bb0 1269 break;
79072805 1270 }
11343788 1271 return o;
79072805
LW		 1272}
1273
1274OP *
864dbfa3 1275Perl_scalarvoid(pTHX_ OP *o)
79072805 1276{
27da23d5 1277 dVAR;
79072805 1278 OP *kid;
c445ea15 1279 const char* useless = NULL;
34ee6772 1280 U32 useless_is_utf8 = 0;
8990e307 1281 SV* sv;
2ebea0a1
GS		 1282 U8 want;
1283
7918f24d
NC		 1284 PERL_ARGS_ASSERT_SCALARVOID;
1285
eb8433b7
NC		 1286 /* trailing mad null ops don't count as "there" for void processing */
1287 if (PL_madskills &&
1288 o->op_type != OP_NULL &&
1289 o->op_sibling &&
1290 o->op_sibling->op_type == OP_NULL)
1291 {
1292 OP *sib;
1293 for (sib = o->op_sibling;
1294 sib && sib->op_type == OP_NULL;
1295 sib = sib->op_sibling) ;
1296
1297 if (!sib)
1298 return o;
1299 }
1300
acb36ea4 1301 if (o->op_type == OP_NEXTSTATE
acb36ea4
GS		 1302 || o->op_type == OP_DBSTATE
1303 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
acb36ea4 1304 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1305 PL_curcop = (COP*)o; /* for warning below */
79072805 1306
54310121 1307 /* assumes no premature commitment */
2ebea0a1 1308 want = o->op_flags & OPf_WANT;
13765c85
DM		 1309 if ((want && want != OPf_WANT_SCALAR)
1310 || (PL_parser && PL_parser->error_count)
25b991bf 1311 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
7e363e51 1312 {
11343788 1313 return o;
7e363e51 1314 }
79072805 1315
b162f9ea 1316 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1317 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1318 {
b162f9ea 1319 return scalar(o); /* As if inside SASSIGN */
7e363e51 1320 }
1c846c1f 1321
5dc0d613 1322 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1323
11343788 1324 switch (o->op_type) {
79072805 1325 default:
22c35a8c 1326 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1327 break;
36477c24 1328 /* FALL THROUGH */
1329 case OP_REPEAT:
11343788 1330 if (o->op_flags & OPf_STACKED)
8990e307 1331 break;
5d82c453
GA		 1332 goto func_ops;
1333 case OP_SUBSTR:
1334 if (o->op_private == 4)
1335 break;
8990e307
LW		 1336 /* FALL THROUGH */
1337 case OP_GVSV:
1338 case OP_WANTARRAY:
1339 case OP_GV:
74295f0b 1340 case OP_SMARTMATCH:
8990e307
LW		 1341 case OP_PADSV:
1342 case OP_PADAV:
1343 case OP_PADHV:
1344 case OP_PADANY:
1345 case OP_AV2ARYLEN:
8990e307 1346 case OP_REF:
a0d0e21e
LW		 1347 case OP_REFGEN:
1348 case OP_SREFGEN:
8990e307
LW		 1349 case OP_DEFINED:
1350 case OP_HEX:
1351 case OP_OCT:
1352 case OP_LENGTH:
8990e307
LW		 1353 case OP_VEC:
1354 case OP_INDEX:
1355 case OP_RINDEX:
1356 case OP_SPRINTF:
1357 case OP_AELEM:
1358 case OP_AELEMFAST:
93bad3fd 1359 case OP_AELEMFAST_LEX:
8990e307 1360 case OP_ASLICE:
8990e307
LW		 1361 case OP_HELEM:
1362 case OP_HSLICE:
1363 case OP_UNPACK:
1364 case OP_PACK:
8990e307
LW		 1365 case OP_JOIN:
1366 case OP_LSLICE:
1367 case OP_ANONLIST:
1368 case OP_ANONHASH:
1369 case OP_SORT:
1370 case OP_REVERSE:
1371 case OP_RANGE:
1372 case OP_FLIP:
1373 case OP_FLOP:
1374 case OP_CALLER:
1375 case OP_FILENO:
1376 case OP_EOF:
1377 case OP_TELL:
1378 case OP_GETSOCKNAME:
1379 case OP_GETPEERNAME:
1380 case OP_READLINK:
1381 case OP_TELLDIR:
1382 case OP_GETPPID:
1383 case OP_GETPGRP:
1384 case OP_GETPRIORITY:
1385 case OP_TIME:
1386 case OP_TMS:
1387 case OP_LOCALTIME:
1388 case OP_GMTIME:
1389 case OP_GHBYNAME:
1390 case OP_GHBYADDR:
1391 case OP_GHOSTENT:
1392 case OP_GNBYNAME:
1393 case OP_GNBYADDR:
1394 case OP_GNETENT:
1395 case OP_GPBYNAME:
1396 case OP_GPBYNUMBER:
1397 case OP_GPROTOENT:
1398 case OP_GSBYNAME:
1399 case OP_GSBYPORT:
1400 case OP_GSERVENT:
1401 case OP_GPWNAM:
1402 case OP_GPWUID:
1403 case OP_GGRNAM:
1404 case OP_GGRGID:
1405 case OP_GETLOGIN:
78e1b766 1406 case OP_PROTOTYPE:
703227f5 1407 case OP_RUNCV:
5d82c453 1408 func_ops:
64aac5a9 1409 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
74295f0b 1410 /* Otherwise it's "Useless use of grep iterator" */
f5df4782 1411 useless = OP_DESC(o);
75068674
RGS		 1412 break;
1413
1414 case OP_SPLIT:
1415 kid = cLISTOPo->op_first;
1416 if (kid && kid->op_type == OP_PUSHRE
1417#ifdef USE_ITHREADS
1418 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1419#else
1420 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1421#endif
1422 useless = OP_DESC(o);
8990e307
LW		 1423 break;
1424
9f82cd5f
YST		 1425 case OP_NOT:
1426 kid = cUNOPo->op_first;
1427 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
bb16bae8 1428 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
9f82cd5f
YST		 1429 goto func_ops;
1430 }
1431 useless = "negative pattern binding (!~)";
1432 break;
1433
4f4d7508
DC		 1434 case OP_SUBST:
1435 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
8db9069c 1436 useless = "non-destructive substitution (s///r)";
4f4d7508
DC		 1437 break;
1438
bb16bae8
FC		 1439 case OP_TRANSR:
1440 useless = "non-destructive transliteration (tr///r)";
1441 break;
1442
8990e307
LW		 1443 case OP_RV2GV:
1444 case OP_RV2SV:
1445 case OP_RV2AV:
1446 case OP_RV2HV:
192587c2 1447 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1448 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1449 useless = "a variable";
1450 break;
79072805
LW		 1451
1452 case OP_CONST:
7766f137 1453 sv = cSVOPo_sv;
7a52d87a
GS		 1454 if (cSVOPo->op_private & OPpCONST_STRICT)
1455 no_bareword_allowed(o);
1456 else {
d008e5eb 1457 if (ckWARN(WARN_VOID)) {
e7fec78e 1458 /* don't warn on optimised away booleans, eg
b5a930ec 1459 * use constant Foo, 5; Foo || print; */
e7fec78e 1460 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1461 useless = NULL;
960b4253
MG		 1462 /* the constants 0 and 1 are permitted as they are
1463 conventionally used as dummies in constructs like
1464 1 while some_condition_with_side_effects; */
e7fec78e 1465 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 1466 useless = NULL;
d008e5eb 1467 else if (SvPOK(sv)) {
a52fe3ac
A		 1468 /* perl4's way of mixing documentation and code
1469 (before the invention of POD) was based on a
1470 trick to mix nroff and perl code. The trick was
1471 built upon these three nroff macros being used in
1472 void context. The pink camel has the details in
1473 the script wrapman near page 319. */
6136c704
AL		 1474 const char * const maybe_macro = SvPVX_const(sv);
1475 if (strnEQ(maybe_macro, "di", 2) ||
1476 strnEQ(maybe_macro, "ds", 2) ||
1477 strnEQ(maybe_macro, "ig", 2))
d4c19fe8 1478 useless = NULL;
919f76a3 1479 else {
d3bcd21f 1480 SV * const dsv = newSVpvs("");
919f76a3
RGS		 1481 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1482 "a constant (%s)",
1483 pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
1484 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
1485 SvREFCNT_dec(dsv);
1486 useless = SvPV_nolen(msv);
1487 useless_is_utf8 = SvUTF8(msv);
1488 }
d008e5eb 1489 }
919f76a3
RGS		 1490 else if (SvOK(sv)) {
1491 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1492 "a constant (%"SVf")", sv));
1493 useless = SvPV_nolen(msv);
1494 }
1495 else
1496 useless = "a constant (undef)";
8990e307
LW		 1497 }
1498 }
93c66552 1499 op_null(o); /* don't execute or even remember it */
79072805
LW		 1500 break;
1501
1502 case OP_POSTINC:
11343788 1503 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1504 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 1505 break;
1506
1507 case OP_POSTDEC:
11343788 1508 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1509 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 1510 break;
1511
679d6c4e
HS		 1512 case OP_I_POSTINC:
1513 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1514 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1515 break;
1516
1517 case OP_I_POSTDEC:
1518 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1519 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1520 break;
1521
f2f8fd84
GG		 1522 case OP_SASSIGN: {
1523 OP *rv2gv;
1524 UNOP *refgen, *rv2cv;
1525 LISTOP *exlist;
1526
1527 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1528 break;
1529
1530 rv2gv = ((BINOP *)o)->op_last;
1531 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1532 break;
1533
1534 refgen = (UNOP *)((BINOP *)o)->op_first;
1535
1536 if (!refgen || refgen->op_type != OP_REFGEN)
1537 break;
1538
1539 exlist = (LISTOP *)refgen->op_first;
1540 if (!exlist || exlist->op_type != OP_NULL
1541 || exlist->op_targ != OP_LIST)
1542 break;
1543
1544 if (exlist->op_first->op_type != OP_PUSHMARK)
1545 break;
1546
1547 rv2cv = (UNOP*)exlist->op_last;
1548
1549 if (rv2cv->op_type != OP_RV2CV)
1550 break;
1551
1552 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1553 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1554 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1555
1556 o->op_private |= OPpASSIGN_CV_TO_GV;
1557 rv2gv->op_private |= OPpDONT_INIT_GV;
1558 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1559
1560 break;
1561 }
1562
540dd770
GG		 1563 case OP_AASSIGN: {
1564 inplace_aassign(o);
1565 break;
1566 }
1567
79072805
LW		 1568 case OP_OR:
1569 case OP_AND:
edbe35ea
VP		 1570 kid = cLOGOPo->op_first;
1571 if (kid->op_type == OP_NOT
1572 && (kid->op_flags & OPf_KIDS)
1573 && !PL_madskills) {
1574 if (o->op_type == OP_AND) {
1575 o->op_type = OP_OR;
1576 o->op_ppaddr = PL_ppaddr[OP_OR];
1577 } else {
1578 o->op_type = OP_AND;
1579 o->op_ppaddr = PL_ppaddr[OP_AND];
1580 }
1581 op_null(kid);
1582 }
1583
c963b151 1584 case OP_DOR:
79072805 1585 case OP_COND_EXPR:
0d863452
RH		 1586 case OP_ENTERGIVEN:
1587 case OP_ENTERWHEN:
11343788 1588 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1589 scalarvoid(kid);
1590 break;
5aabfad6 1591
a0d0e21e 1592 case OP_NULL:
11343788 1593 if (o->op_flags & OPf_STACKED)
a0d0e21e 1594 break;
5aabfad6 1595 /* FALL THROUGH */
2ebea0a1
GS		 1596 case OP_NEXTSTATE:
1597 case OP_DBSTATE:
79072805
LW		 1598 case OP_ENTERTRY:
1599 case OP_ENTER:
11343788 1600 if (!(o->op_flags & OPf_KIDS))
79072805 1601 break;
54310121 1602 /* FALL THROUGH */
463ee0b2 1603 case OP_SCOPE:
79072805
LW		 1604 case OP_LEAVE:
1605 case OP_LEAVETRY:
a0d0e21e 1606 case OP_LEAVELOOP:
79072805 1607 case OP_LINESEQ:
79072805 1608 case OP_LIST:
0d863452
RH		 1609 case OP_LEAVEGIVEN:
1610 case OP_LEAVEWHEN:
11343788 1611 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1612 scalarvoid(kid);
1613 break;
c90c0ff4 1614 case OP_ENTEREVAL:
5196be3e 1615 scalarkids(o);
c90c0ff4 1616 break;
d6483035 1617 case OP_SCALAR:
5196be3e 1618 return scalar(o);
79072805 1619 }
a2a5de95 1620 if (useless)
34ee6772
BF		 1621 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1622 newSVpvn_flags(useless, strlen(useless),
1623 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
11343788 1624 return o;
79072805
LW		 1625}
1626
1f676739 1627static OP *
412da003 1628S_listkids(pTHX_ OP *o)
79072805 1629{
11343788 1630 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1631 OP *kid;
11343788 1632 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1633 list(kid);
1634 }
11343788 1635 return o;
79072805
LW		 1636}
1637
1638OP *
864dbfa3 1639Perl_list(pTHX_ OP *o)
79072805 1640{
27da23d5 1641 dVAR;
79072805
LW		 1642 OP *kid;
1643
a0d0e21e 1644 /* assumes no premature commitment */
13765c85
DM		 1645 if (!o || (o->op_flags & OPf_WANT)
1646 || (PL_parser && PL_parser->error_count)
5dc0d613 1647 || o->op_type == OP_RETURN)
7e363e51 1648 {
11343788 1649 return o;
7e363e51 1650 }
79072805 1651
b162f9ea 1652 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1653 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1654 {
b162f9ea 1655 return o; /* As if inside SASSIGN */
7e363e51 1656 }
1c846c1f 1657
5dc0d613 1658 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1659
11343788 1660 switch (o->op_type) {
79072805
LW		 1661 case OP_FLOP:
1662 case OP_REPEAT:
11343788 1663 list(cBINOPo->op_first);
79072805
LW		 1664 break;
1665 case OP_OR:
1666 case OP_AND:
1667 case OP_COND_EXPR:
11343788 1668 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1669 list(kid);
1670 break;
1671 default:
1672 case OP_MATCH:
8782bef2 1673 case OP_QR:
79072805
LW		 1674 case OP_SUBST:
1675 case OP_NULL:
11343788 1676 if (!(o->op_flags & OPf_KIDS))
79072805 1677 break;
11343788
MB		 1678 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1679 list(cBINOPo->op_first);
1680 return gen_constant_list(o);
79072805
LW		 1681 }
1682 case OP_LIST:
11343788 1683 listkids(o);
79072805
LW		 1684 break;
1685 case OP_LEAVE:
1686 case OP_LEAVETRY:
5dc0d613 1687 kid = cLISTOPo->op_first;
54310121 1688 list(kid);
25b991bf
VP		 1689 kid = kid->op_sibling;
1690 do_kids:
1691 while (kid) {
1692 OP *sib = kid->op_sibling;
c08f093b
VP		 1693 if (sib && kid->op_type != OP_LEAVEWHEN)
1694 scalarvoid(kid);
1695 else
54310121 1696 list(kid);
25b991bf 1697 kid = sib;
54310121 1698 }
11206fdd 1699 PL_curcop = &PL_compiling;
54310121 1700 break;
748a9306 1701 case OP_SCOPE:
79072805 1702 case OP_LINESEQ:
25b991bf
VP		 1703 kid = cLISTOPo->op_first;
1704 goto do_kids;
79072805 1705 }
11343788 1706 return o;
79072805
LW		 1707}
1708
1f676739 1709static OP *
2dd5337b 1710S_scalarseq(pTHX_ OP *o)
79072805 1711{
97aff369 1712 dVAR;
11343788 1713 if (o) {
1496a290
AL		 1714 const OPCODE type = o->op_type;
1715
1716 if (type == OP_LINESEQ || type == OP_SCOPE ||
1717 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1718 {
6867be6d 1719 OP *kid;
11343788 1720 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1721 if (kid->op_sibling) {
463ee0b2 1722 scalarvoid(kid);
ed6116ce 1723 }
463ee0b2 1724 }
3280af22 1725 PL_curcop = &PL_compiling;
79072805 1726 }
11343788 1727 o->op_flags &= ~OPf_PARENS;
3280af22 1728 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1729 o->op_flags |= OPf_PARENS;
79072805 1730 }
8990e307 1731 else
11343788
MB		 1732 o = newOP(OP_STUB, 0);
1733 return o;
79072805
LW		 1734}
1735
76e3520e 1736STATIC OP *
cea2e8a9 1737S_modkids(pTHX_ OP *o, I32 type)
79072805 1738{
11343788 1739 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1740 OP *kid;
11343788 1741 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
3ad73efd 1742 op_lvalue(kid, type);
79072805 1743 }
11343788 1744 return o;
79072805
LW		 1745}
1746
3ad73efd 1747/*
d164302a
GG		 1748=for apidoc finalize_optree
1749
1750This function finalizes the optree. Should be called directly after
1751the complete optree is built. It does some additional
1752checking which can't be done in the normal ck_xxx functions and makes
1753the tree thread-safe.
1754
1755=cut
1756*/
1757void
1758Perl_finalize_optree(pTHX_ OP* o)
1759{
1760 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1761
1762 ENTER;
1763 SAVEVPTR(PL_curcop);
1764
1765 finalize_op(o);
1766
1767 LEAVE;
1768}
1769
60dde6b2 1770STATIC void
d164302a
GG		 1771S_finalize_op(pTHX_ OP* o)
1772{
1773 PERL_ARGS_ASSERT_FINALIZE_OP;
1774
1775#if defined(PERL_MAD) && defined(USE_ITHREADS)
1776 {
1777 /* Make sure mad ops are also thread-safe */
1778 MADPROP *mp = o->op_madprop;
1779 while (mp) {
1780 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1781 OP *prop_op = (OP *) mp->mad_val;
1782 /* We only need "Relocate sv to the pad for thread safety.", but this
1783 easiest way to make sure it traverses everything */
4dc304e0
FC		 1784 if (prop_op->op_type == OP_CONST)
1785 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
d164302a
GG		 1786 finalize_op(prop_op);
1787 }
1788 mp = mp->mad_next;
1789 }
1790 }
1791#endif
1792
1793 switch (o->op_type) {
1794 case OP_NEXTSTATE:
1795 case OP_DBSTATE:
1796 PL_curcop = ((COP*)o); /* for warnings */
1797 break;
1798 case OP_EXEC:
ea31ed66
GG		 1799 if ( o->op_sibling
1800 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
d164302a
GG		 1801 && ckWARN(WARN_SYNTAX))
1802 {
ea31ed66
GG		 1803 if (o->op_sibling->op_sibling) {
1804 const OPCODE type = o->op_sibling->op_sibling->op_type;
d164302a
GG		 1805 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1806 const line_t oldline = CopLINE(PL_curcop);
ea31ed66 1807 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
d164302a
GG		 1808 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1809 "Statement unlikely to be reached");
1810 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1811 "\t(Maybe you meant system() when you said exec()?)\n");
1812 CopLINE_set(PL_curcop, oldline);
1813 }
1814 }
1815 }
1816 break;
1817
1818 case OP_GV:
1819 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1820 GV * const gv = cGVOPo_gv;
1821 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1822 /* XXX could check prototype here instead of just carping */
1823 SV * const sv = sv_newmortal();
1824 gv_efullname3(sv, gv, NULL);
1825 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1826 "%"SVf"() called too early to check prototype",
1827 SVfARG(sv));
1828 }
1829 }
1830 break;
1831
1832 case OP_CONST:
eb796c7f
GG		 1833 if (cSVOPo->op_private & OPpCONST_STRICT)
1834 no_bareword_allowed(o);
1835 /* FALLTHROUGH */
d164302a
GG		 1836#ifdef USE_ITHREADS
1837 case OP_HINTSEVAL:
1838 case OP_METHOD_NAMED:
1839 /* Relocate sv to the pad for thread safety.
1840 * Despite being a "constant", the SV is written to,
1841 * for reference counts, sv_upgrade() etc. */
1842 if (cSVOPo->op_sv) {
1843 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1844 if (o->op_type != OP_METHOD_NAMED &&
1845 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1846 {
1847 /* If op_sv is already a PADTMP/MY then it is being used by
1848 * some pad, so make a copy. */
1849 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1850 SvREADONLY_on(PAD_SVl(ix));
1851 SvREFCNT_dec(cSVOPo->op_sv);
1852 }
1853 else if (o->op_type != OP_METHOD_NAMED
1854 && cSVOPo->op_sv == &PL_sv_undef) {
1855 /* PL_sv_undef is hack - it's unsafe to store it in the
1856 AV that is the pad, because av_fetch treats values of
1857 PL_sv_undef as a "free" AV entry and will merrily
1858 replace them with a new SV, causing pad_alloc to think
1859 that this pad slot is free. (When, clearly, it is not)
1860 */
1861 SvOK_off(PAD_SVl(ix));
1862 SvPADTMP_on(PAD_SVl(ix));
1863 SvREADONLY_on(PAD_SVl(ix));
1864 }
1865 else {
1866 SvREFCNT_dec(PAD_SVl(ix));
1867 SvPADTMP_on(cSVOPo->op_sv);
1868 PAD_SETSV(ix, cSVOPo->op_sv);
1869 /* XXX I don't know how this isn't readonly already. */
1870 SvREADONLY_on(PAD_SVl(ix));
1871 }
1872 cSVOPo->op_sv = NULL;
1873 o->op_targ = ix;
1874 }
1875#endif
1876 break;
1877
1878 case OP_HELEM: {
1879 UNOP *rop;
1880 SV *lexname;
1881 GV **fields;
1882 SV **svp, *sv;
1883 const char *key = NULL;
1884 STRLEN keylen;
1885
1886 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1887 break;
1888
1889 /* Make the CONST have a shared SV */
1890 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1891 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1892 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1893 key = SvPV_const(sv, keylen);
1894 lexname = newSVpvn_share(key,
1895 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1896 0);
1897 SvREFCNT_dec(sv);
1898 *svp = lexname;
1899 }
1900
1901 if ((o->op_private & (OPpLVAL_INTRO)))
1902 break;
1903
1904 rop = (UNOP*)((BINOP*)o)->op_first;
1905 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1906 break;
1907 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1908 if (!SvPAD_TYPED(lexname))
1909 break;
1910 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1911 if (!fields || !GvHV(*fields))
1912 break;
1913 key = SvPV_const(*svp, keylen);
1914 if (!hv_fetch(GvHV(*fields), key,
1915 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1916 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1917 "in variable %"SVf" of type %"HEKf,
ce16c625 1918 SVfARG(*svp), SVfARG(lexname),
84cf752c 1919 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG		 1920 }
1921 break;
1922 }
1923
1924 case OP_HSLICE: {
1925 UNOP *rop;
1926 SV *lexname;
1927 GV **fields;
1928 SV **svp;
1929 const char *key;
1930 STRLEN keylen;
1931 SVOP *first_key_op, *key_op;
1932
1933 if ((o->op_private & (OPpLVAL_INTRO))
1934 /* I bet there's always a pushmark... */
1935 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1936 /* hmmm, no optimization if list contains only one key. */
1937 break;
1938 rop = (UNOP*)((LISTOP*)o)->op_last;
1939 if (rop->op_type != OP_RV2HV)
1940 break;
1941 if (rop->op_first->op_type == OP_PADSV)
1942 /* @$hash{qw(keys here)} */
1943 rop = (UNOP*)rop->op_first;
1944 else {
1945 /* @{$hash}{qw(keys here)} */
1946 if (rop->op_first->op_type == OP_SCOPE
1947 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1948 {
1949 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1950 }
1951 else
1952 break;
1953 }
1954
1955 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1956 if (!SvPAD_TYPED(lexname))
1957 break;
1958 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1959 if (!fields || !GvHV(*fields))
1960 break;
1961 /* Again guessing that the pushmark can be jumped over.... */
1962 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1963 ->op_first->op_sibling;
1964 for (key_op = first_key_op; key_op;
1965 key_op = (SVOP*)key_op->op_sibling) {
1966 if (key_op->op_type != OP_CONST)
1967 continue;
1968 svp = cSVOPx_svp(key_op);
1969 key = SvPV_const(*svp, keylen);
1970 if (!hv_fetch(GvHV(*fields), key,
1971 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1972 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1973 "in variable %"SVf" of type %"HEKf,
ce16c625 1974 SVfARG(*svp), SVfARG(lexname),
84cf752c 1975 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG		 1976 }
1977 }
1978 break;
1979 }
1980 case OP_SUBST: {
1981 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1982 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1983 break;
1984 }
1985 default:
1986 break;
1987 }
1988
1989 if (o->op_flags & OPf_KIDS) {
1990 OP *kid;
1991 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1992 finalize_op(kid);
1993 }
1994}
1995
1996/*
3ad73efd
Z		 1997=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1998
1999Propagate lvalue ("modifiable") context to an op and its children.
2000I<type> represents the context type, roughly based on the type of op that
2001would do the modifying, although C<local()> is represented by OP_NULL,
2002because it has no op type of its own (it is signalled by a flag on
001c3c51
FC		 2003the lvalue op).
2004
2005This function detects things that can't be modified, such as C<$x+1>, and
2006generates errors for them. For example, C<$x+1 = 2> would cause it to be
2007called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2008
2009It also flags things that need to behave specially in an lvalue context,
2010such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z		 2011
2012=cut
2013*/
ddeae0f1 2014
79072805 2015OP *
d3d7d28f 2016Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 2017{
27da23d5 2018 dVAR;
79072805 2019 OP *kid;
ddeae0f1
DM		 2020 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2021 int localize = -1;
79072805 2022
13765c85 2023 if (!o || (PL_parser && PL_parser->error_count))
11343788 2024 return o;
79072805 2025
b162f9ea 2026 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 2027 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2028 {
b162f9ea 2029 return o;
7e363e51 2030 }
1c846c1f 2031
5c906035
GG		 2032 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2033
69974ce6
FC		 2034 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2035
11343788 2036 switch (o->op_type) {
68dc0745 2037 case OP_UNDEF:
3280af22 2038 PL_modcount++;
5dc0d613 2039 return o;
5f05dabc 2040 case OP_STUB:
58bde88d 2041 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc 2042 break;
2043 goto nomod;
a0d0e21e 2044 case OP_ENTERSUB:
f79aa60b 2045 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788
MB		 2046 !(o->op_flags & OPf_STACKED)) {
2047 o->op_type = OP_RV2CV; /* entersub => rv2cv */
767eda44
FC		 2048 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2049 poses, so we need it clear. */
e26df76a 2050 o->op_private &= ~1;
22c35a8c 2051 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2052 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2053 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 2054 break;
2055 }
cd06dffe 2056 else { /* lvalue subroutine call */
777d9014
FC		 2057 o->op_private |= OPpLVAL_INTRO
2058 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
e6438c1a 2059 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 2060 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
d0887bf3 2061 /* Potential lvalue context: */
cd06dffe
GS		 2062 o->op_private |= OPpENTERSUB_INARGS;
2063 break;
2064 }
2065 else { /* Compile-time error message: */
2066 OP *kid = cUNOPo->op_first;
2067 CV *cv;
cd06dffe 2068
3ea285d1
AL		 2069 if (kid->op_type != OP_PUSHMARK) {
2070 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2071 Perl_croak(aTHX_
2072 "panic: unexpected lvalue entersub "
2073 "args: type/targ %ld:%"UVuf,
2074 (long)kid->op_type, (UV)kid->op_targ);
2075 kid = kLISTOP->op_first;
2076 }
cd06dffe
GS		 2077 while (kid->op_sibling)
2078 kid = kid->op_sibling;
2079 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS		 2080 break; /* Postpone until runtime */
2081 }
b2ffa427 2082
cd06dffe
GS		 2083 kid = kUNOP->op_first;
2084 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2085 kid = kUNOP->op_first;
b2ffa427 2086 if (kid->op_type == OP_NULL)
cd06dffe
GS		 2087 Perl_croak(aTHX_
2088 "Unexpected constant lvalue entersub "
55140b79 2089 "entry via type/targ %ld:%"UVuf,
3d811634 2090 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 2091 if (kid->op_type != OP_GV) {
cd06dffe
GS		 2092 break;
2093 }
b2ffa427 2094
638eceb6 2095 cv = GvCV(kGVOP_gv);
1c846c1f 2096 if (!cv)
da1dff94 2097 break;
cd06dffe
GS		 2098 if (CvLVALUE(cv))
2099 break;
2100 }
2101 }
79072805
LW		 2102 /* FALL THROUGH */
2103 default:
a0d0e21e 2104 nomod:
f5d552b4 2105 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 2106 /* grep, foreach, subcalls, refgen */
145b2bbb
FC		 2107 if (type == OP_GREPSTART || type == OP_ENTERSUB
2108 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 2109 break;
cea2e8a9 2110 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 2111 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 2112 ? "do block"
2113 : (o->op_type == OP_ENTERSUB
2114 ? "non-lvalue subroutine call"
53e06cf0 2115 : OP_DESC(o))),
22c35a8c 2116 type ? PL_op_desc[type] : "local"));
11343788 2117 return o;
79072805 2118
a0d0e21e
LW		 2119 case OP_PREINC:
2120 case OP_PREDEC:
2121 case OP_POW:
2122 case OP_MULTIPLY:
2123 case OP_DIVIDE:
2124 case OP_MODULO:
2125 case OP_REPEAT:
2126 case OP_ADD:
2127 case OP_SUBTRACT:
2128 case OP_CONCAT:
2129 case OP_LEFT_SHIFT:
2130 case OP_RIGHT_SHIFT:
2131 case OP_BIT_AND:
2132 case OP_BIT_XOR:
2133 case OP_BIT_OR:
2134 case OP_I_MULTIPLY:
2135 case OP_I_DIVIDE:
2136 case OP_I_MODULO:
2137 case OP_I_ADD:
2138 case OP_I_SUBTRACT:
11343788 2139 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 2140 goto nomod;
3280af22 2141 PL_modcount++;
a0d0e21e 2142 break;
b2ffa427 2143
79072805 2144 case OP_COND_EXPR:
ddeae0f1 2145 localize = 1;
11343788 2146 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 2147 op_lvalue(kid, type);
79072805
LW		 2148 break;
2149
2150 case OP_RV2AV:
2151 case OP_RV2HV:
11343788 2152 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 2153 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 2154 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 2155 }
2156 /* FALL THROUGH */
79072805 2157 case OP_RV2GV:
5dc0d613 2158 if (scalar_mod_type(o, type))
3fe9a6f1 2159 goto nomod;
11343788 2160 ref(cUNOPo->op_first, o->op_type);
79072805 2161 /* FALL THROUGH */
79072805
LW		 2162 case OP_ASLICE:
2163 case OP_HSLICE:
78f9721b
SM		 2164 if (type == OP_LEAVESUBLV)
2165 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 2166 localize = 1;
78f9721b
SM		 2167 /* FALL THROUGH */
2168 case OP_AASSIGN:
93a17b20
LW		 2169 case OP_NEXTSTATE:
2170 case OP_DBSTATE:
e6438c1a 2171 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 2172 break;
28c5b5bc
RGS		 2173 case OP_AV2ARYLEN:
2174 PL_hints |= HINT_BLOCK_SCOPE;
2175 if (type == OP_LEAVESUBLV)
2176 o->op_private |= OPpMAYBE_LVSUB;
2177 PL_modcount++;
2178 break;
463ee0b2 2179 case OP_RV2SV:
aeea060c 2180 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 2181 localize = 1;
463ee0b2 2182 /* FALL THROUGH */
79072805 2183 case OP_GV:
3280af22 2184 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 2185 case OP_SASSIGN:
bf4b1e52
GS		 2186 case OP_ANDASSIGN:
2187 case OP_ORASSIGN:
c963b151 2188 case OP_DORASSIGN:
ddeae0f1
DM		 2189 PL_modcount++;
2190 break;
2191
8990e307 2192 case OP_AELEMFAST:
93bad3fd 2193 case OP_AELEMFAST_LEX:
6a077020 2194 localize = -1;
3280af22 2195 PL_modcount++;
8990e307
LW		 2196 break;
2197
748a9306
LW		 2198 case OP_PADAV:
2199 case OP_PADHV:
e6438c1a 2200 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 2201 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2202 return o; /* Treat \(@foo) like ordinary list. */
2203 if (scalar_mod_type(o, type))
3fe9a6f1 2204 goto nomod;
78f9721b
SM		 2205 if (type == OP_LEAVESUBLV)
2206 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 2207 /* FALL THROUGH */
2208 case OP_PADSV:
3280af22 2209 PL_modcount++;
ddeae0f1 2210 if (!type) /* local() */
5ede95a0
BF		 2211 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2212 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW		 2213 break;
2214
748a9306 2215 case OP_PUSHMARK:
ddeae0f1 2216 localize = 0;
748a9306 2217 break;
b2ffa427 2218
69969c6f 2219 case OP_KEYS:
d8065907 2220 case OP_RKEYS:
fad4a2e4 2221 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 2222 goto nomod;
5d82c453
GA		 2223 goto lvalue_func;
2224 case OP_SUBSTR:
2225 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2226 goto nomod;
5f05dabc 2227 /* FALL THROUGH */
a0d0e21e 2228 case OP_POS:
463ee0b2 2229 case OP_VEC:
fad4a2e4 2230 lvalue_func:
78f9721b
SM		 2231 if (type == OP_LEAVESUBLV)
2232 o->op_private |= OPpMAYBE_LVSUB;
11343788
MB		 2233 pad_free(o->op_targ);
2234 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 2235 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788 2236 if (o->op_flags & OPf_KIDS)
3ad73efd 2237 op_lvalue(cBINOPo->op_first->op_sibling, type);
463ee0b2 2238 break;
a0d0e21e 2239
463ee0b2
LW		 2240 case OP_AELEM:
2241 case OP_HELEM:
11343788 2242 ref(cBINOPo->op_first, o->op_type);
68dc0745 2243 if (type == OP_ENTERSUB &&
5dc0d613
MB		 2244 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2245 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 2246 if (type == OP_LEAVESUBLV)
2247 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 2248 localize = 1;
3280af22 2249 PL_modcount++;
463ee0b2
LW		 2250 break;
2251
2252 case OP_SCOPE:
2253 case OP_LEAVE:
2254 case OP_ENTER:
78f9721b 2255 case OP_LINESEQ:
ddeae0f1 2256 localize = 0;
11343788 2257 if (o->op_flags & OPf_KIDS)
3ad73efd 2258 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW		 2259 break;
2260
2261 case OP_NULL:
ddeae0f1 2262 localize = 0;
638bc118
GS		 2263 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2264 goto nomod;
2265 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2266 break;
11343788 2267 if (o->op_targ != OP_LIST) {
3ad73efd 2268 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW		 2269 break;
2270 }
2271 /* FALL THROUGH */
463ee0b2 2272 case OP_LIST:
ddeae0f1 2273 localize = 0;
11343788 2274 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
5c906035
GG		 2275 /* elements might be in void context because the list is
2276 in scalar context or because they are attribute sub calls */
2277 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2278 op_lvalue(kid, type);
463ee0b2 2279 break;
78f9721b
SM		 2280
2281 case OP_RETURN:
2282 if (type != OP_LEAVESUBLV)
2283 goto nomod;
3ad73efd 2284 break; /* op_lvalue()ing was handled by ck_return() */
1efec5ed
FC		 2285
2286 case OP_COREARGS:
2287 return o;
463ee0b2 2288 }
58d95175 2289
8be1be90
AMS		 2290 /* [20011101.069] File test operators interpret OPf_REF to mean that
2291 their argument is a filehandle; thus \stat(".") should not set
2292 it. AMS 20011102 */
2293 if (type == OP_REFGEN &&
ef69c8fc 2294 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS		 2295 return o;
2296
2297 if (type != OP_LEAVESUBLV)
2298 o->op_flags |= OPf_MOD;
2299
2300 if (type == OP_AASSIGN || type == OP_SASSIGN)
2301 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 2302 else if (!type) { /* local() */
2303 switch (localize) {
2304 case 1:
2305 o->op_private |= OPpLVAL_INTRO;
2306 o->op_flags &= ~OPf_SPECIAL;
2307 PL_hints |= HINT_BLOCK_SCOPE;
2308 break;
2309 case 0:
2310 break;
2311 case -1:
a2a5de95
NC		 2312 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2313 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2314 }
463ee0b2 2315 }
8be1be90
AMS		 2316 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2317 && type != OP_LEAVESUBLV)
2318 o->op_flags |= OPf_REF;
11343788 2319 return o;
463ee0b2
LW		 2320}
2321
864dbfa3 2322STATIC bool
5f66b61c 2323S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 2324{
2325 switch (type) {
32a60974 2326 case OP_POS:
3fe9a6f1 2327 case OP_SASSIGN:
1efec5ed 2328 if (o && o->op_type == OP_RV2GV)
3fe9a6f1 2329 return FALSE;
2330 /* FALL THROUGH */
2331 case OP_PREINC:
2332 case OP_PREDEC:
2333 case OP_POSTINC:
2334 case OP_POSTDEC:
2335 case OP_I_PREINC:
2336 case OP_I_PREDEC:
2337 case OP_I_POSTINC:
2338 case OP_I_POSTDEC:
2339 case OP_POW:
2340 case OP_MULTIPLY:
2341 case OP_DIVIDE:
2342 case OP_MODULO:
2343 case OP_REPEAT:
2344 case OP_ADD:
2345 case OP_SUBTRACT:
2346 case OP_I_MULTIPLY:
2347 case OP_I_DIVIDE:
2348 case OP_I_MODULO:
2349 case OP_I_ADD:
2350 case OP_I_SUBTRACT:
2351 case OP_LEFT_SHIFT:
2352 case OP_RIGHT_SHIFT:
2353 case OP_BIT_AND:
2354 case OP_BIT_XOR:
2355 case OP_BIT_OR:
2356 case OP_CONCAT:
2357 case OP_SUBST:
2358 case OP_TRANS:
bb16bae8 2359 case OP_TRANSR:
49e9fbe6
GS		 2360 case OP_READ:
2361 case OP_SYSREAD:
2362 case OP_RECV:
bf4b1e52
GS		 2363 case OP_ANDASSIGN:
2364 case OP_ORASSIGN:
410d09fe 2365 case OP_DORASSIGN:
3fe9a6f1 2366 return TRUE;
2367 default:
2368 return FALSE;
2369 }
2370}
2371
35cd451c 2372STATIC bool
5f66b61c 2373S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2374{
7918f24d
NC		 2375 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2376
35cd451c
GS		 2377 switch (o->op_type) {
2378 case OP_PIPE_OP:
2379 case OP_SOCKPAIR:
504618e9 2380 if (numargs == 2)
35cd451c
GS		 2381 return TRUE;
2382 /* FALL THROUGH */
2383 case OP_SYSOPEN:
2384 case OP_OPEN:
ded8aa31 2385 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 2386 case OP_SOCKET:
2387 case OP_OPEN_DIR:
2388 case OP_ACCEPT:
504618e9 2389 if (numargs == 1)
35cd451c 2390 return TRUE;
5f66b61c 2391 /* FALLTHROUGH */
35cd451c
GS		 2392 default:
2393 return FALSE;
2394 }
2395}
2396
0d86688d
NC		 2397static OP *
2398S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2399{
11343788 2400 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2401 OP *kid;
11343788 2402 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 2403 ref(kid, type);
2404 }
11343788 2405 return o;
463ee0b2
LW		 2406}
2407
2408OP *
e4c5ccf3 2409Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2410{
27da23d5 2411 dVAR;
463ee0b2 2412 OP *kid;
463ee0b2 2413
7918f24d
NC		 2414 PERL_ARGS_ASSERT_DOREF;
2415
13765c85 2416 if (!o || (PL_parser && PL_parser->error_count))
11343788 2417 return o;
463ee0b2 2418
11343788 2419 switch (o->op_type) {
a0d0e21e 2420 case OP_ENTERSUB:
f4df43b5 2421 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB		 2422 !(o->op_flags & OPf_STACKED)) {
2423 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2424 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2425 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2426 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2427 o->op_flags |= OPf_SPECIAL;
e26df76a 2428 o->op_private &= ~1;
8990e307 2429 }
767eda44 2430 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG		 2431 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2432 : type == OP_RV2HV ? OPpDEREF_HV
2433 : OPpDEREF_SV);
767eda44
FC		 2434 o->op_flags |= OPf_MOD;
2435 }
2436
8990e307 2437 break;
aeea060c 2438
463ee0b2 2439 case OP_COND_EXPR:
11343788 2440 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2441 doref(kid, type, set_op_ref);
463ee0b2 2442 break;
8990e307 2443 case OP_RV2SV:
35cd451c
GS		 2444 if (type == OP_DEFINED)
2445 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2446 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 2447 /* FALL THROUGH */
2448 case OP_PADSV:
5f05dabc 2449 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2450 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2451 : type == OP_RV2HV ? OPpDEREF_HV
2452 : OPpDEREF_SV);
11343788 2453 o->op_flags |= OPf_MOD;
a0d0e21e 2454 }
8990e307 2455 break;
1c846c1f 2456
463ee0b2
LW		 2457 case OP_RV2AV:
2458 case OP_RV2HV:
e4c5ccf3
RH		 2459 if (set_op_ref)
2460 o->op_flags |= OPf_REF;
8990e307 2461 /* FALL THROUGH */
463ee0b2 2462 case OP_RV2GV:
35cd451c
GS		 2463 if (type == OP_DEFINED)
2464 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2465 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2466 break;
8990e307 2467
463ee0b2
LW		 2468 case OP_PADAV:
2469 case OP_PADHV:
e4c5ccf3
RH		 2470 if (set_op_ref)
2471 o->op_flags |= OPf_REF;
79072805 2472 break;
aeea060c 2473
8990e307 2474 case OP_SCALAR:
79072805 2475 case OP_NULL:
11343788 2476 if (!(o->op_flags & OPf_KIDS))
463ee0b2 2477 break;
e4c5ccf3 2478 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 2479 break;
2480 case OP_AELEM:
2481 case OP_HELEM:
e4c5ccf3 2482 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2483 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2484 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2485 : type == OP_RV2HV ? OPpDEREF_HV
2486 : OPpDEREF_SV);
11343788 2487 o->op_flags |= OPf_MOD;
8990e307 2488 }
79072805
LW		 2489 break;
2490
463ee0b2 2491 case OP_SCOPE:
79072805 2492 case OP_LEAVE:
e4c5ccf3
RH		 2493 set_op_ref = FALSE;
2494 /* FALL THROUGH */
79072805 2495 case OP_ENTER:
8990e307 2496 case OP_LIST:
11343788 2497 if (!(o->op_flags & OPf_KIDS))
79072805 2498 break;
e4c5ccf3 2499 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2500 break;
a0d0e21e
LW		 2501 default:
2502 break;
79072805 2503 }
11343788 2504 return scalar(o);
8990e307 2505
79072805
LW		 2506}
2507
09bef843
SB		 2508STATIC OP *
2509S_dup_attrlist(pTHX_ OP *o)
2510{
97aff369 2511 dVAR;
0bd48802 2512 OP *rop;
09bef843 2513
7918f24d
NC		 2514 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2515
09bef843
SB		 2516 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2517 * where the first kid is OP_PUSHMARK and the remaining ones
2518 * are OP_CONST. We need to push the OP_CONST values.
2519 */
2520 if (o->op_type == OP_CONST)
b37c2d43 2521 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 2522#ifdef PERL_MAD
2523 else if (o->op_type == OP_NULL)
1d866c12 2524 rop = NULL;
eb8433b7 2525#endif
09bef843
SB		 2526 else {
2527 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2528 rop = NULL;
09bef843
SB		 2529 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2530 if (o->op_type == OP_CONST)
2fcb4757 2531 rop = op_append_elem(OP_LIST, rop,
09bef843 2532 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2533 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 2534 }
2535 }
2536 return rop;
2537}
2538
2539STATIC void
95f0a2f1 2540S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 2541{
27da23d5 2542 dVAR;
09bef843
SB		 2543 SV *stashsv;
2544
7918f24d
NC		 2545 PERL_ARGS_ASSERT_APPLY_ATTRS;
2546
09bef843
SB		 2547 /* fake up C<use attributes $pkg,$rv,@attrs> */
2548 ENTER; /* need to protect against side-effects of 'use' */
5aaec2b4 2549 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 2550
09bef843 2551#define ATTRSMODULE "attributes"
95f0a2f1
SB		 2552#define ATTRSMODULE_PM "attributes.pm"
2553
2554 if (for_my) {
95f0a2f1 2555 /* Don't force the C<use> if we don't need it. */
a4fc7abc 2556 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 2557 if (svp && *svp != &PL_sv_undef)
6f207bd3 2558 NOOP; /* already in %INC */
95f0a2f1
SB		 2559 else
2560 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 2561 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 2562 }
2563 else {
2564 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 2565 newSVpvs(ATTRSMODULE),
2566 NULL,
2fcb4757 2567 op_prepend_elem(OP_LIST,
95f0a2f1 2568 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2569 op_prepend_elem(OP_LIST,
95f0a2f1
SB		 2570 newSVOP(OP_CONST, 0,
2571 newRV(target)),
2572 dup_attrlist(attrs))));
2573 }
09bef843
SB		 2574 LEAVE;
2575}
2576
95f0a2f1
SB		 2577STATIC void
2578S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2579{
97aff369 2580 dVAR;
95f0a2f1
SB		 2581 OP *pack, *imop, *arg;
2582 SV *meth, *stashsv;
2583
7918f24d
NC		 2584 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2585
95f0a2f1
SB		 2586 if (!attrs)
2587 return;
2588
2589 assert(target->op_type == OP_PADSV ||
2590 target->op_type == OP_PADHV ||
2591 target->op_type == OP_PADAV);
2592
2593 /* Ensure that attributes.pm is loaded. */
dd2155a4 2594 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 2595
2596 /* Need package name for method call. */
6136c704 2597 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 2598
2599 /* Build up the real arg-list. */
5aaec2b4
NC		 2600 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2601
95f0a2f1
SB		 2602 arg = newOP(OP_PADSV, 0);
2603 arg->op_targ = target->op_targ;
2fcb4757 2604 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2605 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2606 op_prepend_elem(OP_LIST,
95f0a2f1 2607 newUNOP(OP_REFGEN, 0,
3ad73efd 2608 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB		 2609 dup_attrlist(attrs)));
2610
2611 /* Fake up a method call to import */
18916d0d 2612 meth = newSVpvs_share("import");
95f0a2f1 2613 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z		 2614 op_append_elem(OP_LIST,
2615 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2616 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB		 2617
2618 /* Combine the ops. */
2fcb4757 2619 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB		 2620}
2621
2622/*
2623=notfor apidoc apply_attrs_string
2624
2625Attempts to apply a list of attributes specified by the C<attrstr> and
2626C<len> arguments to the subroutine identified by the C<cv> argument which
2627is expected to be associated with the package identified by the C<stashpv>
2628argument (see L<attributes>). It gets this wrong, though, in that it
2629does not correctly identify the boundaries of the individual attribute
2630specifications within C<attrstr>. This is not really intended for the
2631public API, but has to be listed here for systems such as AIX which
2632need an explicit export list for symbols. (It's called from XS code
2633in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2634to respect attribute syntax properly would be welcome.
2635
2636=cut
2637*/
2638
be3174d2 2639void
6867be6d
AL		 2640Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2641 const char *attrstr, STRLEN len)
be3174d2 2642{
5f66b61c 2643 OP *attrs = NULL;
be3174d2 2644
7918f24d
NC		 2645 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2646
be3174d2
GS		 2647 if (!len) {
2648 len = strlen(attrstr);
2649 }
2650
2651 while (len) {
2652 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2653 if (len) {
890ce7af 2654 const char * const sstr = attrstr;
be3174d2 2655 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2656 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS		 2657 newSVOP(OP_CONST, 0,
2658 newSVpvn(sstr, attrstr-sstr)));
2659 }
2660 }
2661
2662 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2663 newSVpvs(ATTRSMODULE),
2fcb4757 2664 NULL, op_prepend_elem(OP_LIST,
be3174d2 2665 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2666 op_prepend_elem(OP_LIST,
be3174d2 2667 newSVOP(OP_CONST, 0,
ad64d0ec 2668 newRV(MUTABLE_SV(cv))),
be3174d2
GS		 2669 attrs)));
2670}
2671
09bef843 2672STATIC OP *
95f0a2f1 2673S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2674{
97aff369 2675 dVAR;
93a17b20 2676 I32 type;
a1fba7eb 2677 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2678
7918f24d
NC		 2679 PERL_ARGS_ASSERT_MY_KID;
2680
13765c85 2681 if (!o || (PL_parser && PL_parser->error_count))
11343788 2682 return o;
93a17b20 2683
bc61e325 2684 type = o->op_type;
eb8433b7
NC		 2685 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2686 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2687 return o;
2688 }
2689
93a17b20 2690 if (type == OP_LIST) {
6867be6d 2691 OP *kid;
11343788 2692 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2693 my_kid(kid, attrs, imopsp);
0865059d 2694 return o;
8b8c1fb9 2695 } else if (type == OP_UNDEF || type == OP_STUB) {
7766148a 2696 return o;
77ca0c92
LW		 2697 } else if (type == OP_RV2SV || /* "our" declaration */
2698 type == OP_RV2AV ||
2699 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2700 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2701 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2702 OP_DESC(o),
12bd6ede
DM		 2703 PL_parser->in_my == KEY_our
2704 ? "our"
2705 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2706 } else if (attrs) {
551405c4 2707 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM		 2708 PL_parser->in_my = FALSE;
2709 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS		 2710 apply_attrs(GvSTASH(gv),
2711 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC		 2712 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2713 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
1ce0b88c
RGS		 2714 attrs, FALSE);
2715 }
192587c2 2716 o->op_private |= OPpOUR_INTRO;
77ca0c92 2717 return o;
95f0a2f1
SB		 2718 }
2719 else if (type != OP_PADSV &&
93a17b20
LW		 2720 type != OP_PADAV &&
2721 type != OP_PADHV &&
2722 type != OP_PUSHMARK)
2723 {
eb64745e 2724 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2725 OP_DESC(o),
12bd6ede
DM		 2726 PL_parser->in_my == KEY_our
2727 ? "our"
2728 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2729 return o;
93a17b20 2730 }
09bef843
SB		 2731 else if (attrs && type != OP_PUSHMARK) {
2732 HV *stash;
09bef843 2733
12bd6ede
DM		 2734 PL_parser->in_my = FALSE;
2735 PL_parser->in_my_stash = NULL;
eb64745e 2736
09bef843 2737 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 2738 stash = PAD_COMPNAME_TYPE(o->op_targ);
2739 if (!stash)
09bef843 2740 stash = PL_curstash;
95f0a2f1 2741 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2742 }
11343788
MB		 2743 o->op_flags |= OPf_MOD;
2744 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2745 if (stately)
952306ac 2746 o->op_private |= OPpPAD_STATE;
11343788 2747 return o;
93a17b20
LW		 2748}
2749
2750OP *
09bef843
SB		 2751Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2752{
97aff369 2753 dVAR;
0bd48802 2754 OP *rops;
95f0a2f1
SB		 2755 int maybe_scalar = 0;
2756
7918f24d
NC		 2757 PERL_ARGS_ASSERT_MY_ATTRS;
2758
d2be0de5 2759/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2760 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2761#if 0
09bef843
SB		 2762 if (o->op_flags & OPf_PARENS)
2763 list(o);
95f0a2f1
SB		 2764 else
2765 maybe_scalar = 1;
d2be0de5
YST		 2766#else
2767 maybe_scalar = 1;
2768#endif
09bef843
SB		 2769 if (attrs)
2770 SAVEFREEOP(attrs);
5f66b61c 2771 rops = NULL;
95f0a2f1
SB		 2772 o = my_kid(o, attrs, &rops);
2773 if (rops) {
2774 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2775 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB		 2776 o->op_private |= OPpLVAL_INTRO;
2777 }
f5d1ed10
FC		 2778 else {
2779 /* The listop in rops might have a pushmark at the beginning,
2780 which will mess up list assignment. */
2781 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2782 if (rops->op_type == OP_LIST &&
2783 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2784 {
2785 OP * const pushmark = lrops->op_first;
2786 lrops->op_first = pushmark->op_sibling;
2787 op_free(pushmark);
2788 }
2fcb4757 2789 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2790 }
95f0a2f1 2791 }
12bd6ede
DM		 2792 PL_parser->in_my = FALSE;
2793 PL_parser->in_my_stash = NULL;
eb64745e 2794 return o;
09bef843
SB		 2795}
2796
2797OP *
864dbfa3 2798Perl_sawparens(pTHX_ OP *o)
79072805 2799{
96a5add6 2800 PERL_UNUSED_CONTEXT;
79072805
LW		 2801 if (o)
2802 o->op_flags |= OPf_PARENS;
2803 return o;
2804}
2805
2806OP *
864dbfa3 2807Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2808{
11343788 2809 OP *o;
59f00321 2810 bool ismatchop = 0;
1496a290
AL		 2811 const OPCODE ltype = left->op_type;
2812 const OPCODE rtype = right->op_type;
79072805 2813
7918f24d
NC		 2814 PERL_ARGS_ASSERT_BIND_MATCH;
2815
1496a290
AL		 2816 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2817 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2818 {
1496a290 2819 const char * const desc
bb16bae8
FC		 2820 = PL_op_desc[(
2821 rtype == OP_SUBST || rtype == OP_TRANS
2822 || rtype == OP_TRANSR
2823 )
666ea192 2824 ? (int)rtype : OP_MATCH];
c6771ab6
FC		 2825 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2826 GV *gv;
2827 SV * const name =
2828 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2829 ? cUNOPx(left)->op_first->op_type == OP_GV
2830 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2831 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2832 : NULL
ba510004
FC		 2833 : varname(
2834 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2835 );
c6771ab6
FC		 2836 if (name)
2837 Perl_warner(aTHX_ packWARN(WARN_MISC),
2838 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2839 desc, name, name);
2840 else {
2841 const char * const sample = (isary
666ea192 2842 ? "@array" : "%hash");
c6771ab6 2843 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2844 "Applying %s to %s will act on scalar(%s)",
599cee73 2845 desc, sample, sample);
c6771ab6 2846 }
2ae324a7 2847 }
2848
1496a290 2849 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2850 cSVOPx(right)->op_private & OPpCONST_BARE &&
2851 cSVOPx(right)->op_private & OPpCONST_STRICT)
2852 {
2853 no_bareword_allowed(right);
2854 }
2855
bb16bae8 2856 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC		 2857 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2858 type == OP_NOT)
2859 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC		 2860 if (rtype == OP_TRANSR && type == OP_NOT)
2861 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2862
2474a784
FC		 2863 ismatchop = (rtype == OP_MATCH ||
2864 rtype == OP_SUBST ||
bb16bae8 2865 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2866 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS		 2867 if (ismatchop && right->op_private & OPpTARGET_MY) {
2868 right->op_targ = 0;
2869 right->op_private &= ~OPpTARGET_MY;
2870 }
2871 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2872 OP *newleft;
2873
79072805 2874 right->op_flags |= OPf_STACKED;
bb16bae8 2875 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 2876 ! (rtype == OP_TRANS &&
4f4d7508
DC		 2877 right->op_private & OPpTRANS_IDENTICAL) &&
2878 ! (rtype == OP_SUBST &&
2879 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 2880 newleft = op_lvalue(left, rtype);
1496a290
AL		 2881 else
2882 newleft = left;
bb16bae8 2883 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 2884 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2885 else
2fcb4757 2886 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 2887 if (type == OP_NOT)
11343788
MB		 2888 return newUNOP(OP_NOT, 0, scalar(o));
2889 return o;
79072805
LW		 2890 }
2891 else
2892 return bind_match(type, left,
d63c20f2 2893 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
79072805
LW		 2894}
2895
2896OP *
864dbfa3 2897Perl_invert(pTHX_ OP *o)
79072805 2898{
11343788 2899 if (!o)
1d866c12 2900 return NULL;
11343788 2901 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2902}
2903
3ad73efd
Z		 2904/*
2905=for apidoc Amx|OP *|op_scope|OP *o
2906
2907Wraps up an op tree with some additional ops so that at runtime a dynamic
2908scope will be created. The original ops run in the new dynamic scope,
2909and then, provided that they exit normally, the scope will be unwound.
2910The additional ops used to create and unwind the dynamic scope will
2911normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2912instead if the ops are simple enough to not need the full dynamic scope
2913structure.
2914
2915=cut
2916*/
2917
79072805 2918OP *
3ad73efd 2919Perl_op_scope(pTHX_ OP *o)
79072805 2920{
27da23d5 2921 dVAR;
79072805 2922 if (o) {
3280af22 2923 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2fcb4757 2924 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 2925 o->op_type = OP_LEAVE;
22c35a8c 2926 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2927 }
fdb22418
HS		 2928 else if (o->op_type == OP_LINESEQ) {
2929 OP *kid;
2930 o->op_type = OP_SCOPE;
2931 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2932 kid = ((LISTOP*)o)->op_first;
59110972 2933 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2934 op_null(kid);
59110972
RH		 2935
2936 /* The following deals with things like 'do {1 for 1}' */
2937 kid = kid->op_sibling;
2938 if (kid &&
2939 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2940 op_null(kid);
2941 }
463ee0b2 2942 }
fdb22418 2943 else
5f66b61c 2944 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2945 }
2946 return o;
2947}
1930840b 2948
a0d0e21e 2949int
864dbfa3 2950Perl_block_start(pTHX_ int full)
79072805 2951{
97aff369 2952 dVAR;
73d840c0 2953 const int retval = PL_savestack_ix;
1930840b 2954
dd2155a4 2955 pad_block_start(full);
b3ac6de7 2956 SAVEHINTS();
3280af22 2957 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2958 SAVECOMPILEWARNINGS();
72dc9ed5 2959 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 2960
a88d97bf 2961 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 2962
a0d0e21e
LW		 2963 return retval;
2964}
2965
2966OP*
864dbfa3 2967Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2968{
97aff369 2969 dVAR;
6867be6d 2970 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b
BM		 2971 OP* retval = scalarseq(seq);
2972
a88d97bf 2973 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 2974
e9818f4e 2975 LEAVE_SCOPE(floor);
623e6609 2976 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2977 if (needblockscope)
3280af22 2978 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 2979 pad_leavemy();
1930840b 2980
a88d97bf 2981 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 2982
a0d0e21e
LW		 2983 return retval;
2984}
2985
fd85fad2
BM		 2986/*
2987=head1 Compile-time scope hooks
2988
3e4ddde5 2989=for apidoc Aox||blockhook_register
fd85fad2
BM		 2990
2991Register a set of hooks to be called when the Perl lexical scope changes
2992at compile time. See L<perlguts/"Compile-time scope hooks">.
2993
2994=cut
2995*/
2996
bb6c22e7
BM		 2997void
2998Perl_blockhook_register(pTHX_ BHK *hk)
2999{
3000 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3001
3002 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3003}
3004
76e3520e 3005STATIC OP *
cea2e8a9 3006S_newDEFSVOP(pTHX)
54b9620d 3007{
97aff369 3008 dVAR;
cc76b5cc 3009 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 3010 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 3011 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3012 }
3013 else {
551405c4 3014 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 3015 o->op_targ = offset;
3016 return o;
3017 }
54b9620d
MB		 3018}
3019
a0d0e21e 3020void
864dbfa3 3021Perl_newPROG(pTHX_ OP *o)
a0d0e21e 3022{
97aff369 3023 dVAR;
7918f24d
NC		 3024
3025 PERL_ARGS_ASSERT_NEWPROG;
3026
3280af22 3027 if (PL_in_eval) {
86a64801 3028 PERL_CONTEXT *cx;
63429d50 3029 I32 i;
b295d113
TH		 3030 if (PL_eval_root)
3031 return;
faef0170
HS		 3032 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3033 ((PL_in_eval & EVAL_KEEPERR)
3034 ? OPf_SPECIAL : 0), o);
86a64801
GG		 3035
3036 cx = &cxstack[cxstack_ix];
3037 assert(CxTYPE(cx) == CXt_EVAL);
3038
3039 if ((cx->blk_gimme & G_WANT) == G_VOID)
3040 scalarvoid(PL_eval_root);
3041 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3042 list(PL_eval_root);
3043 else
3044 scalar(PL_eval_root);
3045
5983a79d 3046 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS		 3047 PL_eval_root->op_private |= OPpREFCOUNTED;
3048 OpREFCNT_set(PL_eval_root, 1);
3280af22 3049 PL_eval_root->op_next = 0;
63429d50
FC		 3050 i = PL_savestack_ix;
3051 SAVEFREEOP(o);
3052 ENTER;
a2efc822 3053 CALL_PEEP(PL_eval_start);
86a64801 3054 finalize_optree(PL_eval_root);
63429d50
FC		 3055 LEAVE;
3056 PL_savestack_ix = i;
a0d0e21e
LW		 3057 }
3058 else {
6be89cf9
AE		 3059 if (o->op_type == OP_STUB) {
3060 PL_comppad_name = 0;
3061 PL_compcv = 0;
d2c837a0 3062 S_op_destroy(aTHX_ o);
a0d0e21e 3063 return;
6be89cf9 3064 }
3ad73efd 3065 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS		 3066 PL_curcop = &PL_compiling;
3067 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 3068 PL_main_root->op_private |= OPpREFCOUNTED;
3069 OpREFCNT_set(PL_main_root, 1);
3280af22 3070 PL_main_root->op_next = 0;
a2efc822 3071 CALL_PEEP(PL_main_start);
d164302a 3072 finalize_optree(PL_main_root);
8be227ab 3073 cv_forget_slab(PL_compcv);
3280af22 3074 PL_compcv = 0;
3841441e 3075
4fdae800 3076 /* Register with debugger */
84902520 3077 if (PERLDB_INTER) {
b96d8cd9 3078 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS		 3079 if (cv) {
3080 dSP;
924508f0 3081 PUSHMARK(SP);
ad64d0ec 3082 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 3083 PUTBACK;
ad64d0ec 3084 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS		 3085 }
3086 }
79072805 3087 }
79072805
LW		 3088}
3089
3090OP *
864dbfa3 3091Perl_localize(pTHX_ OP *o, I32 lex)
79072805 3092{
97aff369 3093 dVAR;
7918f24d
NC		 3094
3095 PERL_ARGS_ASSERT_LOCALIZE;
3096
79072805 3097 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 3098/* [perl #17376]: this appears to be premature, and results in code such as
3099 C< our(%x); > executing in list mode rather than void mode */
3100#if 0
79072805 3101 list(o);
d2be0de5 3102#else
6f207bd3 3103 NOOP;
d2be0de5 3104#endif
8990e307 3105 else {
f06b5848
DM		 3106 if ( PL_parser->bufptr > PL_parser->oldbufptr
3107 && PL_parser->bufptr[-1] == ','
041457d9 3108 && ckWARN(WARN_PARENTHESIS))
64420d0d 3109 {
f06b5848 3110 char *s = PL_parser->bufptr;
bac662ee 3111 bool sigil = FALSE;
64420d0d 3112
8473848f 3113 /* some heuristics to detect a potential error */
bac662ee 3114 while (*s && (strchr(", \t\n", *s)))
64420d0d 3115 s++;
8473848f 3116
bac662ee
TS		 3117 while (1) {
3118 if (*s && strchr("@$%*", *s) && *++s
3119 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
3120 s++;
3121 sigil = TRUE;
3122 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
3123 s++;
3124 while (*s && (strchr(", \t\n", *s)))
3125 s++;
3126 }
3127 else
3128 break;
3129 }
3130 if (sigil && (*s == ';' || *s == '=')) {
3131 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 3132 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 3133 lex
3134 ? (PL_parser->in_my == KEY_our
3135 ? "our"
3136 : PL_parser->in_my == KEY_state
3137 ? "state"
3138 : "my")
3139 : "local");
8473848f 3140 }
8990e307
LW		 3141 }
3142 }
93a17b20 3143 if (lex)
eb64745e 3144 o = my(o);
93a17b20 3145 else
3ad73efd 3146 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 3147 PL_parser->in_my = FALSE;
3148 PL_parser->in_my_stash = NULL;
eb64745e 3149 return o;
79072805
LW		 3150}
3151
3152OP *
864dbfa3 3153Perl_jmaybe(pTHX_ OP *o)
79072805 3154{
7918f24d
NC		 3155 PERL_ARGS_ASSERT_JMAYBE;
3156
79072805 3157 if (o->op_type == OP_LIST) {
fafc274c 3158 OP * const o2
d4c19fe8 3159 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 3160 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW		 3161 }
3162 return o;
3163}
3164
985b9e54
GG		 3165PERL_STATIC_INLINE OP *
3166S_op_std_init(pTHX_ OP *o)
3167{
3168 I32 type = o->op_type;
3169
3170 PERL_ARGS_ASSERT_OP_STD_INIT;
3171
3172 if (PL_opargs[type] & OA_RETSCALAR)
3173 scalar(o);
3174 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3175 o->op_targ = pad_alloc(type, SVs_PADTMP);
3176
3177 return o;
3178}
3179
3180PERL_STATIC_INLINE OP *
3181S_op_integerize(pTHX_ OP *o)
3182{
3183 I32 type = o->op_type;
3184
3185 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3186
077da62f
FC		 3187 /* integerize op. */
3188 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
985b9e54 3189 {
f5f19483 3190 dVAR;
985b9e54
GG		 3191 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3192 }
3193
3194 if (type == OP_NEGATE)
3195 /* XXX might want a ck_negate() for this */
3196 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3197
3198 return o;
3199}
3200
1f676739 3201static OP *
b7783a12 3202S_fold_constants(pTHX_ register OP *o)
79072805 3203{
27da23d5 3204 dVAR;
001d637e 3205 register OP * VOL curop;
eb8433b7 3206 OP *newop;
8ea43dc8 3207 VOL I32 type = o->op_type;
e3cbe32f 3208 SV * VOL sv = NULL;
b7f7fd0b
NC		 3209 int ret = 0;
3210 I32 oldscope;
3211 OP *old_next;
5f2d9966
DM		 3212 SV * const oldwarnhook = PL_warnhook;
3213 SV * const olddiehook = PL_diehook;
c427f4d2 3214 COP not_compiling;
b7f7fd0b 3215 dJMPENV;
79072805 3216
7918f24d
NC		 3217 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3218
22c35a8c 3219 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 3220 goto nope;
3221
de939608 3222 switch (type) {
de939608
CS		 3223 case OP_UCFIRST:
3224 case OP_LCFIRST:
3225 case OP_UC:
3226 case OP_LC:
69dcf70c
MB		 3227 case OP_SLT:
3228 case OP_SGT:
3229 case OP_SLE:
3230 case OP_SGE:
3231 case OP_SCMP:
b3fd6149 3232 case OP_SPRINTF:
2de3dbcc 3233 /* XXX what about the numeric ops? */
82ad65bb 3234 if (IN_LOCALE_COMPILETIME)
de939608 3235 goto nope;
553e7bb0 3236 break;
baed7faa
FC		 3237 case OP_REPEAT:
3238 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
de939608
CS		 3239 }
3240
13765c85 3241 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3242 goto nope; /* Don't try to run w/ errors */
3243
79072805 3244 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 3245 const OPCODE type = curop->op_type;
3246 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3247 type != OP_LIST &&
3248 type != OP_SCALAR &&
3249 type != OP_NULL &&
3250 type != OP_PUSHMARK)
7a52d87a 3251 {
79072805
LW		 3252 goto nope;
3253 }
3254 }
3255
3256 curop = LINKLIST(o);
b7f7fd0b 3257 old_next = o->op_next;
79072805 3258 o->op_next = 0;
533c011a 3259 PL_op = curop;
b7f7fd0b
NC		 3260
3261 oldscope = PL_scopestack_ix;
edb2152a 3262 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 3263
c427f4d2
NC		 3264 /* Verify that we don't need to save it: */
3265 assert(PL_curcop == &PL_compiling);
3266 StructCopy(&PL_compiling, &not_compiling, COP);
3267 PL_curcop = &not_compiling;
3268 /* The above ensures that we run with all the correct hints of the
3269 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3270 assert(IN_PERL_RUNTIME);
5f2d9966
DM		 3271 PL_warnhook = PERL_WARNHOOK_FATAL;
3272 PL_diehook = NULL;
b7f7fd0b
NC		 3273 JMPENV_PUSH(ret);
3274
3275 switch (ret) {
3276 case 0:
3277 CALLRUNOPS(aTHX);
3278 sv = *(PL_stack_sp--);
523a0f0c
NC		 3279 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3280#ifdef PERL_MAD
3281 /* Can't simply swipe the SV from the pad, because that relies on
3282 the op being freed "real soon now". Under MAD, this doesn't
3283 happen (see the #ifdef below). */
3284 sv = newSVsv(sv);
3285#else
b7f7fd0b 3286 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC		 3287#endif
3288 }
b7f7fd0b
NC		 3289 else if (SvTEMP(sv)) { /* grab mortal temp? */
3290 SvREFCNT_inc_simple_void(sv);
3291 SvTEMP_off(sv);
3292 }
3293 break;
3294 case 3:
3295 /* Something tried to die. Abandon constant folding. */
3296 /* Pretend the error never happened. */
ab69dbc2 3297 CLEAR_ERRSV();
b7f7fd0b
NC		 3298 o->op_next = old_next;
3299 break;
3300 default:
3301 JMPENV_POP;
5f2d9966
DM		 3302 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3303 PL_warnhook = oldwarnhook;
3304 PL_diehook = olddiehook;
3305 /* XXX note that this croak may fail as we've already blown away
3306 * the stack - eg any nested evals */
b7f7fd0b
NC		 3307 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3308 }
b7f7fd0b 3309 JMPENV_POP;
5f2d9966
DM		 3310 PL_warnhook = oldwarnhook;
3311 PL_diehook = olddiehook;
c427f4d2 3312 PL_curcop = &PL_compiling;
edb2152a
NC		 3313
3314 if (PL_scopestack_ix > oldscope)
3315 delete_eval_scope();
eb8433b7 3316
b7f7fd0b
NC		 3317 if (ret)
3318 goto nope;
3319
eb8433b7 3320#ifndef PERL_MAD
79072805 3321 op_free(o);
eb8433b7 3322#endif
de5e01c2 3323 assert(sv);
79072805 3324 if (type == OP_RV2GV)
159b6efe 3325 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3326 else
ad64d0ec 3327 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
eb8433b7
NC		 3328 op_getmad(o,newop,'f');
3329 return newop;
aeea060c 3330
b7f7fd0b 3331 nope:
79072805
LW		 3332 return o;
3333}
3334
1f676739 3335static OP *
b7783a12 3336S_gen_constant_list(pTHX_ register OP *o)
79072805 3337{
27da23d5 3338 dVAR;
79072805 3339 register OP *curop;
6867be6d 3340 const I32 oldtmps_floor = PL_tmps_floor;
79072805 3341
a0d0e21e 3342 list(o);
13765c85 3343 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3344 return o; /* Don't attempt to run with errors */
3345
533c011a 3346 PL_op = curop = LINKLIST(o);
a0d0e21e 3347 o->op_next = 0;
a2efc822 3348 CALL_PEEP(curop);
897d3989 3349 Perl_pp_pushmark(aTHX);
cea2e8a9 3350 CALLRUNOPS(aTHX);
533c011a 3351 PL_op = curop;
78c72037
NC		 3352 assert (!(curop->op_flags & OPf_SPECIAL));
3353 assert(curop->op_type == OP_RANGE);
897d3989 3354 Perl_pp_anonlist(aTHX);
3280af22 3355 PL_tmps_floor = oldtmps_floor;
79072805
LW		 3356
3357 o->op_type = OP_RV2AV;
22c35a8c 3358 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 3359 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3360 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3361 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3362 curop = ((UNOP*)o)->op_first;
b37c2d43 3363 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 3364#ifdef PERL_MAD
3365 op_getmad(curop,o,'O');
3366#else
79072805 3367 op_free(curop);
eb8433b7 3368#endif
5983a79d 3369 LINKLIST(o);
79072805
LW		 3370 return list(o);
3371}
3372
3373OP *
864dbfa3 3374Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3375{
27da23d5 3376 dVAR;
d67594ff 3377 if (type < 0) type = -type, flags |= OPf_SPECIAL;
11343788 3378 if (!o || o->op_type != OP_LIST)
5f66b61c 3379 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3380 else
5dc0d613 3381 o->op_flags &= ~OPf_WANT;
79072805 3382
22c35a8c 3383 if (!(PL_opargs[type] & OA_MARK))
93c66552 3384 op_null(cLISTOPo->op_first);
bf0571fd
FC		 3385 else {
3386 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3387 if (kid2 && kid2->op_type == OP_COREARGS) {
3388 op_null(cLISTOPo->op_first);
3389 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3390 }
3391 }
8990e307 3392
eb160463 3393 o->op_type = (OPCODE)type;
22c35a8c 3394 o->op_ppaddr = PL_ppaddr[type];
11343788 3395 o->op_flags |= flags;
79072805 3396
11343788 3397 o = CHECKOP(type, o);
fe2774ed 3398 if (o->op_type != (unsigned)type)
11343788 3399 return o;
79072805 3400
985b9e54 3401 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 3402}
3403
2fcb4757
Z		 3404/*
3405=head1 Optree Manipulation Functions
3406*/
3407
79072805
LW		 3408/* List constructors */
3409
2fcb4757
Z		 3410/*
3411=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3412
3413Append an item to the list of ops contained directly within a list-type
3414op, returning the lengthened list. I<first> is the list-type op,
3415and I<last> is the op to append to the list. I<optype> specifies the
3416intended opcode for the list. If I<first> is not already a list of the
3417right type, it will be upgraded into one. If either I<first> or I<last>
3418is null, the other is returned unchanged.
3419
3420=cut
3421*/
3422
79072805 3423OP *
2fcb4757 3424Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3425{
3426 if (!first)
3427 return last;
8990e307
LW		 3428
3429 if (!last)
79072805 3430 return first;
8990e307 3431
fe2774ed 3432 if (first->op_type != (unsigned)type
155aba94
GS		 3433 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3434 {
3435 return newLISTOP(type, 0, first, last);
3436 }
79072805 3437
a0d0e21e
LW		 3438 if (first->op_flags & OPf_KIDS)
3439 ((LISTOP*)first)->op_last->op_sibling = last;
3440 else {
3441 first->op_flags |= OPf_KIDS;
3442 ((LISTOP*)first)->op_first = last;
3443 }
3444 ((LISTOP*)first)->op_last = last;
a0d0e21e 3445 return first;
79072805
LW		 3446}
3447
2fcb4757
Z		 3448/*
3449=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3450
3451Concatenate the lists of ops contained directly within two list-type ops,
3452returning the combined list. I<first> and I<last> are the list-type ops
3453to concatenate. I<optype> specifies the intended opcode for the list.
3454If either I<first> or I<last> is not already a list of the right type,
3455it will be upgraded into one. If either I<first> or I<last> is null,
3456the other is returned unchanged.
3457
3458=cut
3459*/
3460
79072805 3461OP *
2fcb4757 3462Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3463{
3464 if (!first)
2fcb4757 3465 return last;
8990e307
LW		 3466
3467 if (!last)
2fcb4757 3468 return first;
8990e307 3469
fe2774ed 3470 if (first->op_type != (unsigned)type)
2fcb4757 3471 return op_prepend_elem(type, first, last);
8990e307 3472
fe2774ed 3473 if (last->op_type != (unsigned)type)
2fcb4757 3474 return op_append_elem(type, first, last);
79072805 3475
2fcb4757
Z		 3476 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3477 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3478 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3479
eb8433b7 3480#ifdef PERL_MAD
2fcb4757
Z		 3481 if (((LISTOP*)last)->op_first && first->op_madprop) {
3482 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC		 3483 if (mp) {
3484 while (mp->mad_next)
3485 mp = mp->mad_next;
3486 mp->mad_next = first->op_madprop;
3487 }
3488 else {
2fcb4757 3489 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC		 3490 }
3491 }
3492 first->op_madprop = last->op_madprop;
3493 last->op_madprop = 0;
3494#endif
3495
2fcb4757 3496 S_op_destroy(aTHX_ last);
238a4c30 3497
2fcb4757 3498 return first;
79072805
LW		 3499}
3500
2fcb4757
Z		 3501/*
3502=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3503
3504Prepend an item to the list of ops contained directly within a list-type
3505op, returning the lengthened list. I<first> is the op to prepend to the
3506list, and I<last> is the list-type op. I<optype> specifies the intended
3507opcode for the list. If I<last> is not already a list of the right type,
3508it will be upgraded into one. If either I<first> or I<last> is null,
3509the other is returned unchanged.
3510
3511=cut
3512*/
3513
79072805 3514OP *
2fcb4757 3515Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3516{
3517 if (!first)
3518 return last;
8990e307
LW		 3519
3520 if (!last)
79072805 3521 return first;
8990e307 3522
fe2774ed 3523 if (last->op_type == (unsigned)type) {
8990e307
LW		 3524 if (type == OP_LIST) { /* already a PUSHMARK there */
3525 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3526 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 3527 if (!(first->op_flags & OPf_PARENS))
3528 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 3529 }
3530 else {
3531 if (!(last->op_flags & OPf_KIDS)) {
3532 ((LISTOP*)last)->op_last = first;
3533 last->op_flags |= OPf_KIDS;
3534 }
3535 first->op_sibling = ((LISTOP*)last)->op_first;
3536 ((LISTOP*)last)->op_first = first;
79072805 3537 }
117dada2 3538 last->op_flags |= OPf_KIDS;
79072805
LW		 3539 return last;
3540 }
3541
3542 return newLISTOP(type, 0, first, last);
3543}
3544
3545/* Constructors */
3546
eb8433b7
NC		 3547#ifdef PERL_MAD
3548
3549TOKEN *
3550Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3551{
3552 TOKEN *tk;
99129197 3553 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 3554 tk->tk_type = (OPCODE)optype;
3555 tk->tk_type = 12345;
3556 tk->tk_lval = lval;
3557 tk->tk_mad = madprop;
3558 return tk;
3559}
3560
3561void
3562Perl_token_free(pTHX_ TOKEN* tk)
3563{
7918f24d
NC		 3564 PERL_ARGS_ASSERT_TOKEN_FREE;
3565
eb8433b7
NC		 3566 if (tk->tk_type != 12345)
3567 return;
3568 mad_free(tk->tk_mad);
3569 Safefree(tk);
3570}
3571
3572void
3573Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3574{
3575 MADPROP* mp;
3576 MADPROP* tm;
7918f24d
NC		 3577
3578 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3579
eb8433b7
NC		 3580 if (tk->tk_type != 12345) {
3581 Perl_warner(aTHX_ packWARN(WARN_MISC),
3582 "Invalid TOKEN object ignored");
3583 return;
3584 }
3585 tm = tk->tk_mad;
3586 if (!tm)
3587 return;
3588
3589 /* faked up qw list? */
3590 if (slot == '(' &&
3591 tm->mad_type == MAD_SV &&
d503a9ba 3592 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC		 3593 slot = 'x';
3594
3595 if (o) {
3596 mp = o->op_madprop;
3597 if (mp) {
3598 for (;;) {
3599 /* pretend constant fold didn't happen? */
3600 if (mp->mad_key == 'f' &&
3601 (o->op_type == OP_CONST ||
3602 o->op_type == OP_GV) )
3603 {
3604 token_getmad(tk,(OP*)mp->mad_val,slot);
3605 return;
3606 }
3607 if (!mp->mad_next)
3608 break;
3609 mp = mp->mad_next;
3610 }
3611 mp->mad_next = tm;
3612 mp = mp->mad_next;
3613 }
3614 else {
3615 o->op_madprop = tm;
3616 mp = o->op_madprop;
3617 }
3618 if (mp->mad_key == 'X')
3619 mp->mad_key = slot; /* just change the first one */
3620
3621 tk->tk_mad = 0;
3622 }
3623 else
3624 mad_free(tm);
3625 Safefree(tk);
3626}
3627
3628void
3629Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3630{
3631 MADPROP* mp;
3632 if (!from)
3633 return;
3634 if (o) {
3635 mp = o->op_madprop;
3636 if (mp) {
3637 for (;;) {
3638 /* pretend constant fold didn't happen? */
3639 if (mp->mad_key == 'f' &&
3640 (o->op_type == OP_CONST ||
3641 o->op_type == OP_GV) )
3642 {
3643 op_getmad(from,(OP*)mp->mad_val,slot);
3644 return;
3645 }
3646 if (!mp->mad_next)
3647 break;
3648 mp = mp->mad_next;
3649 }
3650 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3651 }
3652 else {
3653 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3654 }
3655 }
3656}
3657
3658void
3659Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3660{
3661 MADPROP* mp;
3662 if (!from)
3663 return;
3664 if (o) {
3665 mp = o->op_madprop;
3666 if (mp) {
3667 for (;;) {
3668 /* pretend constant fold didn't happen? */
3669 if (mp->mad_key == 'f' &&
3670 (o->op_type == OP_CONST ||
3671 o->op_type == OP_GV) )
3672 {
3673 op_getmad(from,(OP*)mp->mad_val,slot);
3674 return;
3675 }
3676 if (!mp->mad_next)
3677 break;
3678 mp = mp->mad_next;
3679 }
3680 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3681 }
3682 else {
3683 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3684 }
3685 }
3686 else {
99129197
NC		 3687 PerlIO_printf(PerlIO_stderr(),
3688 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 3689 op_free(from);
3690 }
3691}
3692
3693void
3694Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3695{
3696 MADPROP* tm;
3697 if (!mp || !o)
3698 return;
3699 if (slot)
3700 mp->mad_key = slot;
3701 tm = o->op_madprop;
3702 o->op_madprop = mp;
3703 for (;;) {
3704 if (!mp->mad_next)
3705 break;
3706 mp = mp->mad_next;
3707 }
3708 mp->mad_next = tm;
3709}
3710
3711void
3712Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3713{
3714 if (!o)
3715 return;
3716 addmad(tm, &(o->op_madprop), slot);
3717}
3718
3719void
3720Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3721{
3722 MADPROP* mp;
3723 if (!tm || !root)
3724 return;
3725 if (slot)
3726 tm->mad_key = slot;
3727 mp = *root;
3728 if (!mp) {
3729 *root = tm;
3730 return;
3731 }
3732 for (;;) {
3733 if (!mp->mad_next)
3734 break;
3735 mp = mp->mad_next;
3736 }
3737 mp->mad_next = tm;
3738}
3739
3740MADPROP *
3741Perl_newMADsv(pTHX_ char key, SV* sv)
3742{
7918f24d
NC		 3743 PERL_ARGS_ASSERT_NEWMADSV;
3744
eb8433b7
NC		 3745 return newMADPROP(key, MAD_SV, sv, 0);
3746}
3747
3748MADPROP *
d503a9ba 3749Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7 3750{
c111d5f1 3751 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
eb8433b7
NC		 3752 mp->mad_next = 0;
3753 mp->mad_key = key;
3754 mp->mad_vlen = vlen;
3755 mp->mad_type = type;
3756 mp->mad_val = val;
3757/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3758 return mp;
3759}
3760
3761void
3762Perl_mad_free(pTHX_ MADPROP* mp)
3763{
3764/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3765 if (!mp)
3766 return;
3767 if (mp->mad_next)
3768 mad_free(mp->mad_next);
bc177e6b 3769/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC		 3770 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3771 switch (mp->mad_type) {
3772 case MAD_NULL:
3773 break;
3774 case MAD_PV:
3775 Safefree((char*)mp->mad_val);
3776 break;
3777 case MAD_OP:
3778 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3779 op_free((OP*)mp->mad_val);
3780 break;
3781 case MAD_SV:
ad64d0ec 3782 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC		 3783 break;
3784 default:
3785 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3786 break;
3787 }
c111d5f1 3788 PerlMemShared_free(mp);
eb8433b7
NC		 3789}
3790
3791#endif
3792
d67eb5f4
Z		 3793/*
3794=head1 Optree construction
3795
3796=for apidoc Am|OP *|newNULLLIST
3797
3798Constructs, checks, and returns a new C<stub> op, which represents an
3799empty list expression.
3800
3801=cut
3802*/
3803
79072805 3804OP *
864dbfa3 3805Perl_newNULLLIST(pTHX)
79072805 3806{
8990e307
LW		 3807 return newOP(OP_STUB, 0);
3808}
3809
1f676739 3810static OP *
b7783a12 3811S_force_list(pTHX_ OP *o)
8990e307 3812{
11343788 3813 if (!o || o->op_type != OP_LIST)
5f66b61c 3814 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 3815 op_null(o);
11343788 3816 return o;
79072805
LW		 3817}
3818
d67eb5f4
Z		 3819/*
3820=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3821
3822Constructs, checks, and returns an op of any list type. I<type> is
3823the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3824C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3825supply up to two ops to be direct children of the list op; they are
3826consumed by this function and become part of the constructed op tree.
3827
3828=cut
3829*/
3830
79072805 3831OP *
864dbfa3 3832Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3833{
27da23d5 3834 dVAR;
79072805
LW		 3835 LISTOP *listop;
3836
e69777c1
GG		 3837 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3838
b7dc083c 3839 NewOp(1101, listop, 1, LISTOP);
79072805 3840
eb160463 3841 listop->op_type = (OPCODE)type;
22c35a8c 3842 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 3843 if (first || last)
3844 flags |= OPf_KIDS;
eb160463 3845 listop->op_flags = (U8)flags;
79072805
LW		 3846
3847 if (!last && first)
3848 last = first;
3849 else if (!first && last)
3850 first = last;
8990e307
LW		 3851 else if (first)
3852 first->op_sibling = last;
79072805
LW		 3853 listop->op_first = first;
3854 listop->op_last = last;
8990e307 3855 if (type == OP_LIST) {
551405c4 3856 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 3857 pushop->op_sibling = first;
3858 listop->op_first = pushop;
3859 listop->op_flags |= OPf_KIDS;
3860 if (!last)
3861 listop->op_last = pushop;
3862 }
79072805 3863
463d09e6 3864 return CHECKOP(type, listop);
79072805
LW		 3865}
3866
d67eb5f4
Z		 3867/*
3868=for apidoc Am|OP *|newOP|I32 type|I32 flags
3869
3870Constructs, checks, and returns an op of any base type (any type that
3871has no extra fields). I<type> is the opcode. I<flags> gives the
3872eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3873of C<op_private>.
3874
3875=cut
3876*/
3877
79072805 3878OP *
864dbfa3 3879Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 3880{
27da23d5 3881 dVAR;
11343788 3882 OP *o;
e69777c1 3883
7d789282
FC		 3884 if (type == -OP_ENTEREVAL) {
3885 type = OP_ENTEREVAL;
3886 flags |= OPpEVAL_BYTES<<8;
3887 }
3888
e69777c1
GG		 3889 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3890 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3891 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3892 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3893
b7dc083c 3894 NewOp(1101, o, 1, OP);
eb160463 3895 o->op_type = (OPCODE)type;
22c35a8c 3896 o->op_ppaddr = PL_ppaddr[type];
eb160463 3897 o->op_flags = (U8)flags;
670f3923
DM		 3898 o->op_latefree = 0;
3899 o->op_latefreed = 0;
7e5d8ed2 3900 o->op_attached = 0;
79072805 3901
11343788 3902 o->op_next = o;
eb160463 3903 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 3904 if (PL_opargs[type] & OA_RETSCALAR)
11343788 3905 scalar(o);
22c35a8c 3906 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 3907 o->op_targ = pad_alloc(type, SVs_PADTMP);
3908 return CHECKOP(type, o);
79072805
LW		 3909}
3910
d67eb5f4
Z		 3911/*
3912=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3913
3914Constructs, checks, and returns an op of any unary type. I<type> is
3915the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3916C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3917bits, the eight bits of C<op_private>, except that the bit with value 1
3918is automatically set. I<first> supplies an optional op to be the direct
3919child of the unary op; it is consumed by this function and become part
3920of the constructed op tree.
3921
3922=cut
3923*/
3924
79072805 3925OP *
864dbfa3 3926Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 3927{
27da23d5 3928 dVAR;
79072805
LW		 3929 UNOP *unop;
3930
7d789282
FC		 3931 if (type == -OP_ENTEREVAL) {
3932 type = OP_ENTEREVAL;
3933 flags |= OPpEVAL_BYTES<<8;
3934 }
3935
e69777c1
GG		 3936 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3937 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3938 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3939 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3940 || type == OP_SASSIGN
32e2a35d 3941 || type == OP_ENTERTRY
e69777c1
GG		 3942 || type == OP_NULL );
3943
93a17b20 3944 if (!first)
aeea060c 3945 first = newOP(OP_STUB, 0);
22c35a8c 3946 if (PL_opargs[type] & OA_MARK)
8990e307 3947 first = force_list(first);
93a17b20 3948
b7dc083c 3949 NewOp(1101, unop, 1, UNOP);
eb160463 3950 unop->op_type = (OPCODE)type;
22c35a8c 3951 unop->op_ppaddr = PL_ppaddr[type];
79072805 3952 unop->op_first = first;
585ec06d 3953 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 3954 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 3955 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 3956 if (unop->op_next)
3957 return (OP*)unop;
3958
985b9e54 3959 return fold_constants(op_integerize(op_std_init((OP *) unop)));
79072805
LW		 3960}
3961
d67eb5f4
Z		 3962/*
3963=for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3964
3965Constructs, checks, and returns an op of any binary type. I<type>
3966is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3967that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3968the eight bits of C<op_private>, except that the bit with value 1 or
39692 is automatically set as required. I<first> and I<last> supply up to
3970two ops to be the direct children of the binary op; they are consumed
3971by this function and become part of the constructed op tree.
3972
3973=cut
3974*/
3975
79072805 3976OP *
864dbfa3 3977Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3978{
27da23d5 3979 dVAR;
79072805 3980 BINOP *binop;
e69777c1
GG		 3981
3982 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3983 || type == OP_SASSIGN || type == OP_NULL );
3984
b7dc083c 3985 NewOp(1101, binop, 1, BINOP);
79072805
LW		 3986
3987 if (!first)
3988 first = newOP(OP_NULL, 0);
3989
eb160463 3990 binop->op_type = (OPCODE)type;
22c35a8c 3991 binop->op_ppaddr = PL_ppaddr[type];
79072805 3992 binop->op_first = first;
585ec06d 3993 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 3994 if (!last) {
3995 last = first;
eb160463 3996 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3997 }
3998 else {
eb160463 3999 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 4000 first->op_sibling = last;
4001 }
4002
e50aee73 4003 binop = (BINOP*)CHECKOP(type, binop);
eb160463 4004 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 4005 return (OP*)binop;
4006
7284ab6f 4007 binop->op_last = binop->op_first->op_sibling;
79072805 4008
985b9e54 4009 return fold_constants(op_integerize(op_std_init((OP *)binop)));
79072805
LW		 4010}
4011
5f66b61c
AL		 4012static int uvcompare(const void *a, const void *b)
4013 __attribute__nonnull__(1)
4014 __attribute__nonnull__(2)
4015 __attribute__pure__;
abb2c242 4016static int uvcompare(const void *a, const void *b)
2b9d42f0 4017{
e1ec3a88 4018 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 4019 return -1;
e1ec3a88 4020 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 4021 return 1;
e1ec3a88 4022 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 4023 return -1;
e1ec3a88 4024 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 4025 return 1;
a0ed51b3
LW		 4026 return 0;
4027}
4028
0d86688d
NC		 4029static OP *
4030S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 4031{
97aff369 4032 dVAR;
2d03de9c 4033 SV * const tstr = ((SVOP*)expr)->op_sv;
fbbb0949
DM		 4034 SV * const rstr =
4035#ifdef PERL_MAD
4036 (repl->op_type == OP_NULL)
4037 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4038#endif
4039 ((SVOP*)repl)->op_sv;
463ee0b2
LW		 4040 STRLEN tlen;
4041 STRLEN rlen;
5c144d81
NC		 4042 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4043 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 4044 register I32 i;
4045 register I32 j;
9b877dbb 4046 I32 grows = 0;
79072805
LW		 4047 register short *tbl;
4048
551405c4
AL		 4049 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4050 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4051 I32 del = o->op_private & OPpTRANS_DELETE;
043e41b8 4052 SV* swash;
7918f24d
NC		 4053
4054 PERL_ARGS_ASSERT_PMTRANS;
4055
800b4dc4 4056 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 4057
036b4402
GS		 4058 if (SvUTF8(tstr))
4059 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 4060
4061 if (SvUTF8(rstr))
036b4402 4062 o->op_private |= OPpTRANS_TO_UTF;
79072805 4063
a0ed51b3 4064 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 4065 SV* const listsv = newSVpvs("# comment\n");
c445ea15 4066 SV* transv = NULL;
5c144d81
NC		 4067 const U8* tend = t + tlen;
4068 const U8* rend = r + rlen;
ba210ebe 4069 STRLEN ulen;
84c133a0
RB		 4070 UV tfirst = 1;
4071 UV tlast = 0;
4072 IV tdiff;
4073 UV rfirst = 1;
4074 UV rlast = 0;
4075 IV rdiff;
4076 IV diff;
a0ed51b3
LW		 4077 I32 none = 0;
4078 U32 max = 0;
4079 I32 bits;
a0ed51b3 4080 I32 havefinal = 0;
9c5ffd7c 4081 U32 final = 0;
551405c4
AL		 4082 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4083 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 4084 U8* tsave = NULL;
4085 U8* rsave = NULL;
9f7f3913 4086 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 4087
4088 if (!from_utf) {
4089 STRLEN len = tlen;
5c144d81 4090 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 4091 tend = t + len;
4092 }
4093 if (!to_utf && rlen) {
4094 STRLEN len = rlen;
5c144d81 4095 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 4096 rend = r + len;
4097 }
a0ed51b3 4098
2b9d42f0
NIS		 4099/* There are several snags with this code on EBCDIC:
4100 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
4101 2. scan_const() in toke.c has encoded chars in native encoding which makes
4102 ranges at least in EBCDIC 0..255 range the bottom odd.
4103*/
4104
a0ed51b3 4105 if (complement) {
89ebb4a3 4106 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 4107 UV *cp;
a0ed51b3 4108 UV nextmin = 0;
a02a5408 4109 Newx(cp, 2*tlen, UV);
a0ed51b3 4110 i = 0;
396482e1 4111 transv = newSVpvs("");
a0ed51b3 4112 while (t < tend) {
9f7f3913 4113 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS		 4114 t += ulen;
4115 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 4116 t++;
9f7f3913 4117 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 4118 t += ulen;
a0ed51b3 4119 }
2b9d42f0
NIS		 4120 else {
4121 cp[2*i+1] = cp[2*i];
4122 }
4123 i++;
a0ed51b3 4124 }
2b9d42f0 4125 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 4126 for (j = 0; j < i; j++) {
2b9d42f0 4127 UV val = cp[2*j];
a0ed51b3
LW		 4128 diff = val - nextmin;
4129 if (diff > 0) {
9041c2e3 4130 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 4131 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 4132 if (diff > 1) {
2b9d42f0 4133 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 4134 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 4135 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 4136 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 4137 }
4138 }
2b9d42f0 4139 val = cp[2*j+1];
a0ed51b3
LW		 4140 if (val >= nextmin)
4141 nextmin = val + 1;
4142 }
9041c2e3 4143 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 4144 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 4145 {
4146 U8 range_mark = UTF_TO_NATIVE(0xff);
4147 sv_catpvn(transv, (char *)&range_mark, 1);
4148 }
6247ead0 4149 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
dfe13c55 4150 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 4151 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 4152 tlen = SvCUR(transv);
4153 tend = t + tlen;
455d824a 4154 Safefree(cp);
a0ed51b3
LW		 4155 }
4156 else if (!rlen && !del) {
4157 r = t; rlen = tlen; rend = tend;
4757a243
LW		 4158 }
4159 if (!squash) {
05d340b8 4160 if ((!rlen && !del) || t == r ||
12ae5dfc 4161 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 4162 {
4757a243 4163 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 4164 }
a0ed51b3
LW		 4165 }
4166
4167 while (t < tend || tfirst <= tlast) {
4168 /* see if we need more "t" chars */
4169 if (tfirst > tlast) {
9f7f3913 4170 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 4171 t += ulen;
2b9d42f0 4172 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 4173 t++;
9f7f3913 4174 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW		 4175 t += ulen;
4176 }
4177 else
4178 tlast = tfirst;
4179 }
4180
4181 /* now see if we need more "r" chars */
4182 if (rfirst > rlast) {
4183 if (r < rend) {
9f7f3913 4184 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 4185 r += ulen;
2b9d42f0 4186 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 4187 r++;
9f7f3913 4188 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW		 4189 r += ulen;
4190 }
4191 else
4192 rlast = rfirst;
4193 }
4194 else {
4195 if (!havefinal++)
4196 final = rlast;
4197 rfirst = rlast = 0xffffffff;
4198 }
4199 }
4200
4201 /* now see which range will peter our first, if either. */
4202 tdiff = tlast - tfirst;
4203 rdiff = rlast - rfirst;
4204
4205 if (tdiff <= rdiff)
4206 diff = tdiff;
4207 else
4208 diff = rdiff;
4209
4210 if (rfirst == 0xffffffff) {
4211 diff = tdiff; /* oops, pretend rdiff is infinite */
4212 if (diff > 0)
894356b3
GS		 4213 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4214 (long)tfirst, (long)tlast);
a0ed51b3 4215 else
894356b3 4216 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 4217 }
4218 else {
4219 if (diff > 0)
894356b3
GS		 4220 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4221 (long)tfirst, (long)(tfirst + diff),
4222 (long)rfirst);
a0ed51b3 4223 else
894356b3
GS		 4224 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4225 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 4226
4227 if (rfirst + diff > max)
4228 max = rfirst + diff;
9b877dbb 4229 if (!grows)
45005bfb
JH		 4230 grows = (tfirst < rfirst &&
4231 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4232 rfirst += diff + 1;
a0ed51b3
LW		 4233 }
4234 tfirst += diff + 1;
4235 }
4236
4237 none = ++max;
4238 if (del)
4239 del = ++max;
4240
4241 if (max > 0xffff)
4242 bits = 32;
4243 else if (max > 0xff)
4244 bits = 16;
4245 else
4246 bits = 8;
4247
ad64d0ec 4248 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
043e41b8
DM		 4249#ifdef USE_ITHREADS
4250 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
4251 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4252 PAD_SETSV(cPADOPo->op_padix, swash);
4253 SvPADTMP_on(swash);
a5446a64 4254 SvREADONLY_on(swash);
043e41b8
DM		 4255#else
4256 cSVOPo->op_sv = swash;
4257#endif
a0ed51b3 4258 SvREFCNT_dec(listsv);
b37c2d43 4259 SvREFCNT_dec(transv);
a0ed51b3 4260
45005bfb 4261 if (!del && havefinal && rlen)
85fbaab2 4262 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
b448e4fe 4263 newSVuv((UV)final), 0);
a0ed51b3 4264
9b877dbb 4265 if (grows)
a0ed51b3
LW		 4266 o->op_private |= OPpTRANS_GROWS;
4267
b37c2d43
AL		 4268 Safefree(tsave);
4269 Safefree(rsave);
9b877dbb 4270
eb8433b7
NC		 4271#ifdef PERL_MAD
4272 op_getmad(expr,o,'e');
4273 op_getmad(repl,o,'r');
4274#else
a0ed51b3
LW		 4275 op_free(expr);
4276 op_free(repl);
eb8433b7 4277#endif
a0ed51b3
LW		 4278 return o;
4279 }
4280
9100eeb1
Z		 4281 tbl = (short*)PerlMemShared_calloc(
4282 (o->op_private & OPpTRANS_COMPLEMENT) &&
4283 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4284 sizeof(short));
4285 cPVOPo->op_pv = (char*)tbl;
79072805 4286 if (complement) {
eb160463 4287 for (i = 0; i < (I32)tlen; i++)
ec49126f 4288 tbl[t[i]] = -1;
79072805
LW		 4289 for (i = 0, j = 0; i < 256; i++) {
4290 if (!tbl[i]) {
eb160463 4291 if (j >= (I32)rlen) {
a0ed51b3 4292 if (del)
79072805
LW		 4293 tbl[i] = -2;
4294 else if (rlen)
ec49126f 4295 tbl[i] = r[j-1];
79072805 4296 else
eb160463 4297 tbl[i] = (short)i;
79072805 4298 }
9b877dbb
IH		 4299 else {
4300 if (i < 128 && r[j] >= 128)
4301 grows = 1;
ec49126f 4302 tbl[i] = r[j++];
9b877dbb 4303 }
79072805
LW		 4304 }
4305 }
05d340b8
JH		 4306 if (!del) {
4307 if (!rlen) {
4308 j = rlen;
4309 if (!squash)
4310 o->op_private |= OPpTRANS_IDENTICAL;
4311 }
eb160463 4312 else if (j >= (I32)rlen)
05d340b8 4313 j = rlen - 1;
10db182f 4314 else {
aa1f7c5b
JH		 4315 tbl =
4316 (short *)
4317 PerlMemShared_realloc(tbl,
4318 (0x101+rlen-j) * sizeof(short));
10db182f
YO		 4319 cPVOPo->op_pv = (char*)tbl;
4320 }
585ec06d 4321 tbl[0x100] = (short)(rlen - j);
eb160463 4322 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 4323 tbl[0x101+i] = r[j+i];
4324 }
79072805
LW		 4325 }
4326 else {
a0ed51b3 4327 if (!rlen && !del) {
79072805 4328 r = t; rlen = tlen;
5d06d08e 4329 if (!squash)
4757a243 4330 o->op_private |= OPpTRANS_IDENTICAL;
79072805 4331 }
94bfe852
RGS		 4332 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4333 o->op_private |= OPpTRANS_IDENTICAL;
4334 }
79072805
LW		 4335 for (i = 0; i < 256; i++)
4336 tbl[i] = -1;
eb160463
GS		 4337 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4338 if (j >= (I32)rlen) {
a0ed51b3 4339 if (del) {
ec49126f 4340 if (tbl[t[i]] == -1)
4341 tbl[t[i]] = -2;
79072805
LW		 4342 continue;
4343 }
4344 --j;
4345 }
9b877dbb
IH		 4346 if (tbl[t[i]] == -1) {
4347 if (t[i] < 128 && r[j] >= 128)
4348 grows = 1;
ec49126f 4349 tbl[t[i]] = r[j];
9b877dbb 4350 }
79072805
LW		 4351 }
4352 }
b08e453b 4353
a2a5de95
NC		 4354 if(del && rlen == tlen) {
4355 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4356 } else if(rlen > tlen) {
4357 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
b08e453b
RB		 4358 }
4359
9b877dbb
IH		 4360 if (grows)
4361 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 4362#ifdef PERL_MAD
4363 op_getmad(expr,o,'e');
4364 op_getmad(repl,o,'r');
4365#else
79072805
LW		 4366 op_free(expr);
4367 op_free(repl);
eb8433b7 4368#endif
79072805 4369
11343788 4370 return o;
79072805
LW		 4371}
4372
d67eb5f4
Z		 4373/*
4374=for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4375
4376Constructs, checks, and returns an op of any pattern matching type.
4377I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4378and, shifted up eight bits, the eight bits of C<op_private>.
4379
4380=cut
4381*/
4382
79072805 4383OP *
864dbfa3 4384Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 4385{
27da23d5 4386 dVAR;
79072805
LW		 4387 PMOP *pmop;
4388
e69777c1
GG		 4389 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4390
b7dc083c 4391 NewOp(1101, pmop, 1, PMOP);
eb160463 4392 pmop->op_type = (OPCODE)type;
22c35a8c 4393 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 4394 pmop->op_flags = (U8)flags;
4395 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 4396
3280af22 4397 if (PL_hints & HINT_RE_TAINT)
c737faaf 4398 pmop->op_pmflags |= PMf_RETAINT;
82ad65bb 4399 if (IN_LOCALE_COMPILETIME) {
a62b1201 4400 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
9de15fec 4401 }
66cbab2c
KW		 4402 else if ((! (PL_hints & HINT_BYTES))
4403 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4404 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4405 {
a62b1201 4406 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
9de15fec 4407 }
1e215989 4408 if (PL_hints & HINT_RE_FLAGS) {
20439bc7
Z		 4409 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4410 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
1e215989
FC		 4411 );
4412 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
20439bc7 4413 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6320bfaf 4414 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
1e215989
FC		 4415 );
4416 if (reflags && SvOK(reflags)) {
dabded94 4417 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
1e215989
FC		 4418 }
4419 }
c737faaf 4420
36477c24 4421
debc9467 4422#ifdef USE_ITHREADS
402d2eb1
NC		 4423 assert(SvPOK(PL_regex_pad[0]));
4424 if (SvCUR(PL_regex_pad[0])) {
4425 /* Pop off the "packed" IV from the end. */
4426 SV *const repointer_list = PL_regex_pad[0];
4427 const char *p = SvEND(repointer_list) - sizeof(IV);
4428 const IV offset = *((IV*)p);
4429
4430 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4431
4432 SvEND_set(repointer_list, p);
4433
110f3028 4434 pmop->op_pmoffset = offset;
14a49a24
NC		 4435 /* This slot should be free, so assert this: */
4436 assert(PL_regex_pad[offset] == &PL_sv_undef);
551405c4 4437 } else {
14a49a24 4438 SV * const repointer = &PL_sv_undef;
9a8b6709 4439 av_push(PL_regex_padav, repointer);
551405c4
AL		 4440 pmop->op_pmoffset = av_len(PL_regex_padav);
4441 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 4442 }
debc9467 4443#endif
1eb1540c 4444
463d09e6 4445 return CHECKOP(type, pmop);
79072805
LW		 4446}
4447
131b3ad0
DM		 4448/* Given some sort of match op o, and an expression expr containing a
4449 * pattern, either compile expr into a regex and attach it to o (if it's
4450 * constant), or convert expr into a runtime regcomp op sequence (if it's
4451 * not)
4452 *
4453 * isreg indicates that the pattern is part of a regex construct, eg
4454 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4455 * split "pattern", which aren't. In the former case, expr will be a list
4456 * if the pattern contains more than one term (eg /a$b/) or if it contains
4457 * a replacement, ie s/// or tr///.
d63c20f2
DM		 4458 *
4459 * When the pattern has been compiled within a new anon CV (for
4460 * qr/(?{...})/ ), then floor indicates the savestack level just before
4461 * the new sub was created
131b3ad0
DM		 4462 */
4463
79072805 4464OP *
d63c20f2 4465Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
79072805 4466{
27da23d5 4467 dVAR;
79072805
LW		 4468 PMOP *pm;
4469 LOGOP *rcop;
ce862d02 4470 I32 repl_has_vars = 0;
5f66b61c 4471 OP* repl = NULL;
74529a43
DM		 4472 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4473 bool is_compiletime;
4474 bool has_code;
131b3ad0 4475
7918f24d
NC		 4476 PERL_ARGS_ASSERT_PMRUNTIME;
4477
74529a43
DM		 4478 /* for s/// and tr///, last element in list is the replacement; pop it */
4479
4480 if (is_trans || o->op_type == OP_SUBST) {
131b3ad0
DM		 4481 OP* kid;
4482 repl = cLISTOPx(expr)->op_last;
4483 kid = cLISTOPx(expr)->op_first;
4484 while (kid->op_sibling != repl)
4485 kid = kid->op_sibling;
5f66b61c 4486 kid->op_sibling = NULL;
131b3ad0
DM		 4487 cLISTOPx(expr)->op_last = kid;
4488 }
79072805 4489
74529a43
DM		 4490 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4491
4492 if (is_trans) {
4493 OP* const oe = expr;
4494 assert(expr->op_type == OP_LIST);
4495 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4496 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4497 expr = cLISTOPx(oe)->op_last;
4498 cLISTOPx(oe)->op_first->op_sibling = NULL;
4499 cLISTOPx(oe)->op_last = NULL;
4500 op_free(oe);
4501
4502 return pmtrans(o, expr, repl);
4503 }
4504
8a45afe5
DM		 4505 /* find whether we have any runtime or code elements;
4506 * at the same time, temporarily set the op_next of each DO block;
4507 * then when we LINKLIST, this will cause the DO blocks to be excluded
4508 * from the op_next chain (and from having LINKLIST recursively
4509 * applied to them). We fix up the DOs specially later */
74529a43
DM		 4510
4511 is_compiletime = 1;
4512 has_code = 0;
4513 if (expr->op_type == OP_LIST) {
4514 OP *o;
4515 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
8a45afe5 4516 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
74529a43 4517 has_code = 1;
8a45afe5
DM		 4518 assert(!o->op_next && o->op_sibling);
4519 o->op_next = o->op_sibling;
4520 }
74529a43
DM		 4521 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4522 is_compiletime = 0;
4523 }
4524 }
68e2671b 4525 else if (expr->op_type != OP_CONST)
74529a43 4526 is_compiletime = 0;
74529a43 4527
8a45afe5
DM		 4528 LINKLIST(expr);
4529
8a45afe5 4530 /* fix up DO blocks; treat each one as a separate little sub */
74529a43 4531
68e2671b 4532 if (expr->op_type == OP_LIST) {
8a45afe5
DM		 4533 OP *o;
4534 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4535 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4536 continue;
4537 o->op_next = NULL; /* undo temporary hack from above */
4538 scalar(o);
4539 LINKLIST(o);
4540 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4541 LISTOP *leave = cLISTOPx(cLISTOPo->op_first);
4542 /* skip ENTER */
4543 assert(leave->op_first->op_type == OP_ENTER);
4544 assert(leave->op_first->op_sibling);
4545 o->op_next = leave->op_first->op_sibling;
4546 /* skip LEAVE */
4547 assert(leave->op_flags & OPf_KIDS);
4548 assert(leave->op_last->op_next = (OP*)leave);
4549 leave->op_next = NULL; /* stop on last op */
4550 op_null((OP*)leave);
9da1dd8f 4551 }
8a45afe5
DM		 4552 else {
4553 /* skip SCOPE */
4554 OP *scope = cLISTOPo->op_first;
4555 assert(scope->op_type == OP_SCOPE);
4556 assert(scope->op_flags & OPf_KIDS);
4557 scope->op_next = NULL; /* stop on last op */
4558 op_null(scope);
9da1dd8f 4559 }
8a45afe5
DM		 4560 /* have to peep the DOs individually as we've removed it from
4561 * the op_next chain */
4562 CALL_PEEP(o);
4563 if (is_compiletime)
4564 /* runtime finalizes as part of finalizing whole tree */
4565 finalize_optree(o);
9da1dd8f 4566 }
9da1dd8f
DM		 4567 }
4568
3280af22 4569 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4570 pm = (PMOP*)o;
d63c20f2 4571 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
79072805 4572
74529a43 4573 if (is_compiletime) {
514a91f1 4574 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
3c13cae6 4575 regexp_engine const *eng = current_re_engine();
5c144d81 4576
0ac6acae 4577 if (o->op_flags & OPf_SPECIAL)
514a91f1 4578 rx_flags |= RXf_SPLIT;
5c144d81 4579
3c13cae6 4580 if (!has_code || !eng->op_comp) {
d63c20f2 4581 /* compile-time simple constant pattern */
d63c20f2
DM		 4582
4583 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4584 /* whoops! we guessed that a qr// had a code block, but we
4585 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4586 * that isn't required now. Note that we have to be pretty
4587 * confident that nothing used that CV's pad while the
4588 * regex was parsed */
4589 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
8be227ab
FC		 4590 /* But we know that one op is using this CV's slab. */
4591 cv_forget_slab(PL_compcv);
d63c20f2
DM		 4592 LEAVE_SCOPE(floor);
4593 pm->op_pmflags &= ~PMf_HAS_CV;
4594 }
4595
e485beb8
DM		 4596 PM_SETRE(pm,
4597 eng->op_comp
4598 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4599 rx_flags, pm->op_pmflags)
4600 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4601 rx_flags, pm->op_pmflags)
4602 );
eb8433b7 4603#ifdef PERL_MAD
68e2671b 4604 op_getmad(expr,(OP*)pm,'e');
eb8433b7 4605#else
68e2671b 4606 op_free(expr);
eb8433b7 4607#endif
68e2671b
DM		 4608 }
4609 else {
d63c20f2 4610 /* compile-time pattern that includes literal code blocks */
3c13cae6 4611 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
732caac7
DM		 4612 rx_flags,
4613 (pm->op_pmflags |
4614 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4615 );
d63c20f2
DM		 4616 PM_SETRE(pm, re);
4617 if (pm->op_pmflags & PMf_HAS_CV) {
4618 CV *cv;
4619 /* this QR op (and the anon sub we embed it in) is never
4620 * actually executed. It's just a placeholder where we can
4621 * squirrel away expr in op_code_list without the peephole
4622 * optimiser etc processing it for a second time */
4623 OP *qr = newPMOP(OP_QR, 0);
4624 ((PMOP*)qr)->op_code_list = expr;
4625
4626 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4627 SvREFCNT_inc_simple_void(PL_compcv);
4628 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4629 ((struct regexp *)SvANY(re))->qr_anoncv = cv;
4630
4631 /* attach the anon CV to the pad so that
4632 * pad_fixup_inner_anons() can find it */
4633 (void)pad_add_anon(cv, o->op_type);
4634 SvREFCNT_inc_simple_void(cv);
8be227ab 4635
8be227ab 4636 cv_forget_slab(cv);
d63c20f2
DM		 4637 }
4638 else {
4639 pm->op_code_list = expr;
4640 }
68e2671b 4641 }
79072805
LW		 4642 }
4643 else {
d63c20f2 4644 /* runtime pattern: build chain of regcomp etc ops */
74529a43 4645 bool reglist;
346d3070 4646 PADOFFSET cv_targ = 0;
74529a43
DM		 4647
4648 reglist = isreg && expr->op_type == OP_LIST;
4649 if (reglist)
4650 op_null(expr);
4651
867940b8
DM		 4652 if (has_code) {
4653 pm->op_code_list = expr;
4654 /* don't free op_code_list; its ops are embedded elsewhere too */
4655 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4656 }
4657
7fb31b92
DM		 4658 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4659 * to allow its op_next to be pointed past the regcomp and
4660 * preceding stacking ops;
4661 * OP_REGCRESET is there to reset taint before executing the
4662 * stacking ops */
4663 if (pm->op_pmflags & PMf_KEEP || PL_tainting)
4664 expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
463ee0b2 4665
d63c20f2
DM		 4666 if (pm->op_pmflags & PMf_HAS_CV) {
4667 /* we have a runtime qr with literal code. This means
4668 * that the qr// has been wrapped in a new CV, which
4669 * means that runtime consts, vars etc will have been compiled
4670 * against a new pad. So... we need to execute those ops
4671 * within the environment of the new CV. So wrap them in a call
4672 * to a new anon sub. i.e. for
4673 *
4674 * qr/a$b(?{...})/,
4675 *
4676 * we build an anon sub that looks like
4677 *
4678 * sub { "a", $b, '(?{...})' }
4679 *
4680 * and call it, passing the returned list to regcomp.
4681 * Or to put it another way, the list of ops that get executed
4682 * are:
4683 *
4684 * normal PMf_HAS_CV
4685 * ------ -------------------
4686 * pushmark (for regcomp)
4687 * pushmark (for entersub)
4688 * pushmark (for refgen)
4689 * anoncode
4690 * refgen
4691 * entersub
4692 * regcreset regcreset
4693 * pushmark pushmark
4694 * const("a") const("a")
4695 * gvsv(b) gvsv(b)
4696 * const("(?{...})") const("(?{...})")
4697 * leavesub
4698 * regcomp regcomp
4699 */
4700
4701 SvREFCNT_inc_simple_void(PL_compcv);
346d3070
DM		 4702 /* these lines are just an unrolled newANONATTRSUB */
4703 expr = newSVOP(OP_ANONCODE, 0,
4704 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4705 cv_targ = expr->op_targ;
4706 expr = newUNOP(OP_REFGEN, 0, expr);
4707
4708 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
d63c20f2
DM		 4709 }
4710
b7dc083c 4711 NewOp(1101, rcop, 1, LOGOP);
79072805 4712 rcop->op_type = OP_REGCOMP;
22c35a8c 4713 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 4714 rcop->op_first = scalar(expr);
131b3ad0
DM		 4715 rcop->op_flags |= OPf_KIDS
4716 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4717 | (reglist ? OPf_STACKED : 0);
188c1910 4718 rcop->op_private = 0;
11343788 4719 rcop->op_other = o;
346d3070 4720 rcop->op_targ = cv_targ;
131b3ad0 4721
b5c19bd7 4722 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
ec192197 4723 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
79072805
LW		 4724
4725 /* establish postfix order */
d63c20f2 4726 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
463ee0b2
LW		 4727 LINKLIST(expr);
4728 rcop->op_next = expr;
4729 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4730 }
4731 else {
4732 rcop->op_next = LINKLIST(expr);
4733 expr->op_next = (OP*)rcop;
4734 }
79072805 4735
2fcb4757 4736 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 4737 }
4738
4739 if (repl) {
748a9306 4740 OP *curop;
0244c3a4 4741 if (pm->op_pmflags & PMf_EVAL) {
6136c704 4742 curop = NULL;
670a9cb2
DM		 4743 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4744 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
0244c3a4 4745 }
748a9306
LW		 4746 else if (repl->op_type == OP_CONST)
4747 curop = repl;
79072805 4748 else {
c445ea15 4749 OP *lastop = NULL;
79072805 4750 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
e80b829c 4751 if (curop->op_type == OP_SCOPE
10250113 4752 || curop->op_type == OP_LEAVE
e80b829c 4753 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
79072805 4754 if (curop->op_type == OP_GV) {
6136c704 4755 GV * const gv = cGVOPx_gv(curop);
ce862d02 4756 repl_has_vars = 1;
f702bf4a 4757 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 4758 break;
4759 }
4760 else if (curop->op_type == OP_RV2CV)
4761 break;
4762 else if (curop->op_type == OP_RV2SV ||
4763 curop->op_type == OP_RV2AV ||
4764 curop->op_type == OP_RV2HV ||
4765 curop->op_type == OP_RV2GV) {
4766 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4767 break;
4768 }
748a9306
LW		 4769 else if (curop->op_type == OP_PADSV ||
4770 curop->op_type == OP_PADAV ||
4771 curop->op_type == OP_PADHV ||
e80b829c
RGS		 4772 curop->op_type == OP_PADANY)
4773 {
ce862d02 4774 repl_has_vars = 1;
748a9306 4775 }
1167e5da 4776 else if (curop->op_type == OP_PUSHRE)
6f207bd3 4777 NOOP; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 4778 else
4779 break;
4780 }
4781 lastop = curop;
4782 }
748a9306 4783 }
ce862d02 4784 if (curop == repl
e80b829c
RGS		 4785 && !(repl_has_vars
4786 && (!PM_GETRE(pm)
07bc277f 4787 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3be69782 4788 {
748a9306 4789 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2fcb4757 4790 op_prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 4791 }
4792 else {
aaa362c4 4793 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02 4794 pm->op_pmflags |= PMf_MAYBE_CONST;
ce862d02 4795 }
b7dc083c 4796 NewOp(1101, rcop, 1, LOGOP);
748a9306 4797 rcop->op_type = OP_SUBSTCONT;
22c35a8c 4798 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 4799 rcop->op_first = scalar(repl);
4800 rcop->op_flags |= OPf_KIDS;
4801 rcop->op_private = 1;
11343788 4802 rcop->op_other = o;
748a9306
LW		 4803
4804 /* establish postfix order */
4805 rcop->op_next = LINKLIST(repl);
4806 repl->op_next = (OP*)rcop;
4807
20e98b0f 4808 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
29f2e912
NC		 4809 assert(!(pm->op_pmflags & PMf_ONCE));
4810 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
748a9306 4811 rcop->op_next = 0;
79072805
LW		 4812 }
4813 }
4814
4815 return (OP*)pm;
4816}
4817
d67eb5f4
Z		 4818/*
4819=for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4820
4821Constructs, checks, and returns an op of any type that involves an
4822embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4823of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4824takes ownership of one reference to it.
4825
4826=cut
4827*/
4828
79072805 4829OP *
864dbfa3 4830Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 4831{
27da23d5 4832 dVAR;
79072805 4833 SVOP *svop;
7918f24d
NC		 4834
4835 PERL_ARGS_ASSERT_NEWSVOP;
4836
e69777c1
GG		 4837 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4838 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4839 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4840
b7dc083c 4841 NewOp(1101, svop, 1, SVOP);
eb160463 4842 svop->op_type = (OPCODE)type;
22c35a8c 4843 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 4844 svop->op_sv = sv;
4845 svop->op_next = (OP*)svop;
eb160463 4846 svop->op_flags = (U8)flags;
22c35a8c 4847 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 4848 scalar((OP*)svop);
22c35a8c 4849 if (PL_opargs[type] & OA_TARGET)
ed6116ce 4850 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 4851 return CHECKOP(type, svop);
79072805
LW		 4852}
4853
392d04bb 4854#ifdef USE_ITHREADS
d67eb5f4
Z		 4855
4856/*
4857=for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4858
4859Constructs, checks, and returns an op of any type that involves a
4860reference to a pad element. I<type> is the opcode. I<flags> gives the
4861eight bits of C<op_flags>. A pad slot is automatically allocated, and
4862is populated with I<sv>; this function takes ownership of one reference
4863to it.
4864
4865This function only exists if Perl has been compiled to use ithreads.
4866
4867=cut
4868*/
4869
79072805 4870OP *
350de78d
GS		 4871Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4872{
27da23d5 4873 dVAR;
350de78d 4874 PADOP *padop;
7918f24d
NC		 4875
4876 PERL_ARGS_ASSERT_NEWPADOP;
4877
e69777c1
GG		 4878 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4879 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4880 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4881
350de78d 4882 NewOp(1101, padop, 1, PADOP);
eb160463 4883 padop->op_type = (OPCODE)type;
350de78d
GS		 4884 padop->op_ppaddr = PL_ppaddr[type];
4885 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 4886 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4887 PAD_SETSV(padop->op_padix, sv);
58182927
NC		 4888 assert(sv);
4889 SvPADTMP_on(sv);
350de78d 4890 padop->op_next = (OP*)padop;
eb160463 4891 padop->op_flags = (U8)flags;
350de78d
GS		 4892 if (PL_opargs[type] & OA_RETSCALAR)
4893 scalar((OP*)padop);
4894 if (PL_opargs[type] & OA_TARGET)
4895 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4896 return CHECKOP(type, padop);
4897}
d67eb5f4
Z		 4898
4899#endif /* !USE_ITHREADS */
4900
4901/*
4902=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4903
4904Constructs, checks, and returns an op of any type that involves an
4905embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4906eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4907reference; calling this function does not transfer ownership of any
4908reference to it.
4909
4910=cut
4911*/
350de78d
GS		 4912
4913OP *
864dbfa3 4914Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 4915{
27da23d5 4916 dVAR;
7918f24d
NC		 4917
4918 PERL_ARGS_ASSERT_NEWGVOP;
4919
350de78d 4920#ifdef USE_ITHREADS
58182927 4921 GvIN_PAD_on(gv);
ff8997d7 4922 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 4923#else
ff8997d7 4924 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 4925#endif
79072805
LW		 4926}
4927
d67eb5f4
Z		 4928/*
4929=for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4930
4931Constructs, checks, and returns an op of any type that involves an
4932embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4933the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4934must have been allocated using L</PerlMemShared_malloc>; the memory will
4935be freed when the op is destroyed.
4936
4937=cut
4938*/
4939
79072805 4940OP *
864dbfa3 4941Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 4942{
27da23d5 4943 dVAR;
5db1eb8d 4944 const bool utf8 = cBOOL(flags & SVf_UTF8);
79072805 4945 PVOP *pvop;
e69777c1 4946
5db1eb8d
BF		 4947 flags &= ~SVf_UTF8;
4948
e69777c1 4949 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
1a35f9ff 4950 || type == OP_RUNCV
e69777c1
GG		 4951 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4952
b7dc083c 4953 NewOp(1101, pvop, 1, PVOP);
eb160463 4954 pvop->op_type = (OPCODE)type;
22c35a8c 4955 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 4956 pvop->op_pv = pv;
4957 pvop->op_next = (OP*)pvop;
eb160463 4958 pvop->op_flags = (U8)flags;
5db1eb8d 4959 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
22c35a8c 4960 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 4961 scalar((OP*)pvop);
22c35a8c 4962 if (PL_opargs[type] & OA_TARGET)
ed6116ce 4963 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 4964 return CHECKOP(type, pvop);
79072805
LW		 4965}
4966
eb8433b7
NC		 4967#ifdef PERL_MAD
4968OP*
4969#else
79072805 4970void
eb8433b7 4971#endif
864dbfa3 4972Perl_package(pTHX_ OP *o)
79072805 4973{
97aff369 4974 dVAR;
bf070237 4975 SV *const sv = cSVOPo->op_sv;
eb8433b7
NC		 4976#ifdef PERL_MAD
4977 OP *pegop;
4978#endif
79072805 4979
7918f24d
NC		 4980 PERL_ARGS_ASSERT_PACKAGE;
4981
03d9f026 4982 SAVEGENERICSV(PL_curstash);
3280af22 4983 save_item(PL_curstname);
de11ba31 4984
03d9f026 4985 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
e1a479c5 4986
bf070237 4987 sv_setsv(PL_curstname, sv);
de11ba31 4988
7ad382f4 4989 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 4990 PL_parser->copline = NOLINE;
4991 PL_parser->expect = XSTATE;
eb8433b7
NC		 4992
4993#ifndef PERL_MAD
4994 op_free(o);
4995#else
4996 if (!PL_madskills) {
4997 op_free(o);
1d866c12 4998 return NULL;
eb8433b7
NC		 4999 }
5000
5001 pegop = newOP(OP_NULL,0);
5002 op_getmad(o,pegop,'P');
5003 return pegop;
5004#endif
79072805
LW		 5005}
5006
6fa4d285
DG		 5007void
5008Perl_package_version( pTHX_ OP *v )
5009{
5010 dVAR;
458818ec 5011 U32 savehints = PL_hints;
6fa4d285 5012 PERL_ARGS_ASSERT_PACKAGE_VERSION;
458818ec 5013 PL_hints &= ~HINT_STRICT_VARS;
e92f586b 5014 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
458818ec 5015 PL_hints = savehints;
6fa4d285
DG		 5016 op_free(v);
5017}
5018
eb8433b7
NC		 5019#ifdef PERL_MAD
5020OP*
5021#else
85e6fe83 5022void
eb8433b7 5023#endif
88d95a4d 5024Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 5025{
97aff369 5026 dVAR;
a0d0e21e 5027 OP *pack;
a0d0e21e 5028 OP *imop;
b1cb66bf 5029 OP *veop;
eb8433b7 5030#ifdef PERL_MAD
d8842ae9 5031 OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
eb8433b7 5032#endif
88e9444c 5033 SV *use_version = NULL;
85e6fe83 5034
7918f24d
NC		 5035 PERL_ARGS_ASSERT_UTILIZE;
5036
88d95a4d 5037 if (idop->op_type != OP_CONST)
cea2e8a9 5038 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 5039
eb8433b7
NC		 5040 if (PL_madskills)
5041 op_getmad(idop,pegop,'U');
5042
5f66b61c 5043 veop = NULL;
b1cb66bf 5044
aec46f14 5045 if (version) {
551405c4 5046 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 5047
eb8433b7
NC		 5048 if (PL_madskills)
5049 op_getmad(version,pegop,'V');
aec46f14 5050 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 5051 arg = version;
5052 }
5053 else {
5054 OP *pack;
0f79a09d 5055 SV *meth;
b1cb66bf 5056
44dcb63b 5057 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
fe13d51d 5058 Perl_croak(aTHX_ "Version number must be a constant number");
b1cb66bf 5059
88d95a4d
JH		 5060 /* Make copy of idop so we don't free it twice */
5061 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 5062
5063 /* Fake up a method call to VERSION */
18916d0d 5064 meth = newSVpvs_share("VERSION");
b1cb66bf 5065 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2fcb4757
Z		 5066 op_append_elem(OP_LIST,
5067 op_prepend_elem(OP_LIST, pack, list(version)),
0f79a09d 5068 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 5069 }
5070 }
aeea060c 5071
a0d0e21e 5072 /* Fake up an import/unimport */
eb8433b7
NC		 5073 if (arg && arg->op_type == OP_STUB) {
5074 if (PL_madskills)
5075 op_getmad(arg,pegop,'S');
4633a7c4 5076 imop = arg; /* no import on explicit () */
eb8433b7 5077 }
88d95a4d 5078 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 5079 imop = NULL; /* use 5.0; */
88e9444c
NC		 5080 if (aver)
5081 use_version = ((SVOP*)idop)->op_sv;
5082 else
468aa647 5083 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 5084 }
4633a7c4 5085 else {
0f79a09d
GS		 5086 SV *meth;
5087
eb8433b7
NC		 5088 if (PL_madskills)
5089 op_getmad(arg,pegop,'A');
5090
88d95a4d
JH		 5091 /* Make copy of idop so we don't free it twice */
5092 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 5093
5094 /* Fake up a method call to import/unimport */
427d62a4 5095 meth = aver
18916d0d 5096 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 5097 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2fcb4757
Z		 5098 op_append_elem(OP_LIST,
5099 op_prepend_elem(OP_LIST, pack, list(arg)),
0f79a09d 5100 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 5101 }
5102
a0d0e21e 5103 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 5104 newATTRSUB(floor,
18916d0d 5105 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL		 5106 NULL,
5107 NULL,
2fcb4757
Z		 5108 op_append_elem(OP_LINESEQ,
5109 op_append_elem(OP_LINESEQ,
bd61b366
SS		 5110 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5111 newSTATEOP(0, NULL, veop)),
5112 newSTATEOP(0, NULL, imop) ));
85e6fe83 5113
88e9444c 5114 if (use_version) {
6634bb9d 5115 /* Enable the
88e9444c
NC		 5116 * feature bundle that corresponds to the required version. */
5117 use_version = sv_2mortal(new_version(use_version));
6634bb9d 5118 S_enable_feature_bundle(aTHX_ use_version);
88e9444c 5119
88e9444c
NC		 5120 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5121 if (vcmp(use_version,
5122 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
d1718a7c 5123 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
b50b2058 5124 PL_hints |= HINT_STRICT_REFS;
d1718a7c 5125 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
b50b2058 5126 PL_hints |= HINT_STRICT_SUBS;
d1718a7c 5127 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
b50b2058
FC		 5128 PL_hints |= HINT_STRICT_VARS;
5129 }
5130 /* otherwise they are off */
5131 else {
d1718a7c 5132 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
b50b2058 5133 PL_hints &= ~HINT_STRICT_REFS;
d1718a7c 5134 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
b50b2058 5135 PL_hints &= ~HINT_STRICT_SUBS;
d1718a7c 5136 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
b50b2058 5137 PL_hints &= ~HINT_STRICT_VARS;
88e9444c
NC		 5138 }
5139 }
5140
70f5e4ed
JH		 5141 /* The "did you use incorrect case?" warning used to be here.
5142 * The problem is that on case-insensitive filesystems one
5143 * might get false positives for "use" (and "require"):
5144 * "use Strict" or "require CARP" will work. This causes
5145 * portability problems for the script: in case-strict
5146 * filesystems the script will stop working.
5147 *
5148 * The "incorrect case" warning checked whether "use Foo"
5149 * imported "Foo" to your namespace, but that is wrong, too:
5150 * there is no requirement nor promise in the language that
5151 * a Foo.pm should or would contain anything in package "Foo".
5152 *
5153 * There is very little Configure-wise that can be done, either:
5154 * the case-sensitivity of the build filesystem of Perl does not
5155 * help in guessing the case-sensitivity of the runtime environment.
5156 */
18fc9488 5157
c305c6a0 5158 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 5159 PL_parser->copline = NOLINE;
5160 PL_parser->expect = XSTATE;
8ec8fbef 5161 PL_cop_seqmax++; /* Purely for B::*'s benefit */
6012dc80
DM		 5162 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5163 PL_cop_seqmax++;
eb8433b7
NC		 5164
5165#ifdef PERL_MAD
eb8433b7
NC		 5166 return pegop;
5167#endif
85e6fe83
LW		 5168}
5169
7d3fb230 5170/*
ccfc67b7
JH		 5171=head1 Embedding Functions
5172
7d3fb230
BS		 5173=for apidoc load_module
5174
5175Loads the module whose name is pointed to by the string part of name.
5176Note that the actual module name, not its filename, should be given.
5177Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5178PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
d9f23c72 5179(or 0 for no flags). ver, if specified and not NULL, provides version semantics
7d3fb230
BS		 5180similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5181arguments can be used to specify arguments to the module's import()
76f108ac
JD		 5182method, similar to C<use Foo::Bar VERSION LIST>. They must be
5183terminated with a final NULL pointer. Note that this list can only
5184be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5185Otherwise at least a single NULL pointer to designate the default
5186import list is required.
7d3fb230 5187
d9f23c72
KW		 5188The reference count for each specified C<SV*> parameter is decremented.
5189
7d3fb230
BS		 5190=cut */
5191
e4783991
GS		 5192void
5193Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5194{
5195 va_list args;
7918f24d
NC		 5196
5197 PERL_ARGS_ASSERT_LOAD_MODULE;
5198
e4783991
GS		 5199 va_start(args, ver);
5200 vload_module(flags, name, ver, &args);
5201 va_end(args);
5202}
5203
5204#ifdef PERL_IMPLICIT_CONTEXT
5205void
5206Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5207{
5208 dTHX;
5209 va_list args;
7918f24d 5210 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
e4783991
GS		 5211 va_start(args, ver);
5212 vload_module(flags, name, ver, &args);
5213 va_end(args);
5214}
5215#endif
5216
5217void
5218Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5219{
97aff369 5220 dVAR;
551405c4 5221 OP *veop, *imop;
551405c4 5222 OP * const modname = newSVOP(OP_CONST, 0, name);
7918f24d
NC		 5223
5224 PERL_ARGS_ASSERT_VLOAD_MODULE;
5225
e4783991
GS		 5226 modname->op_private |= OPpCONST_BARE;
5227 if (ver) {
5228 veop = newSVOP(OP_CONST, 0, ver);
5229 }
5230 else
5f66b61c 5231 veop = NULL;
e4783991
GS		 5232 if (flags & PERL_LOADMOD_NOIMPORT) {
5233 imop = sawparens(newNULLLIST());
5234 }
5235 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5236 imop = va_arg(*args, OP*);
5237 }
5238 else {
5239 SV *sv;
5f66b61c 5240 imop = NULL;
e4783991
GS		 5241 sv = va_arg(*args, SV*);
5242 while (sv) {
2fcb4757 5243 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
e4783991
GS		 5244 sv = va_arg(*args, SV*);
5245 }
5246 }
81885997 5247
53a7735b
DM		 5248 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5249 * that it has a PL_parser to play with while doing that, and also
5250 * that it doesn't mess with any existing parser, by creating a tmp
5251 * new parser with lex_start(). This won't actually be used for much,
5252 * since pp_require() will create another parser for the real work. */
5253
5254 ENTER;
5255 SAVEVPTR(PL_curcop);
27fcb6ee 5256 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
53a7735b
DM		 5257 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5258 veop, modname, imop);
5259 LEAVE;
e4783991
GS		 5260}
5261
79072805 5262OP *
850e8516 5263Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 5264{
97aff369 5265 dVAR;
78ca652e 5266 OP *doop;
a0714e2c 5267 GV *gv = NULL;
78ca652e 5268
7918f24d
NC		 5269 PERL_ARGS_ASSERT_DOFILE;
5270
850e8516 5271 if (!force_builtin) {
fafc274c 5272 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
850e8516 5273 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 5274 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
a0714e2c 5275 gv = gvp ? *gvp : NULL;
850e8516
RGS		 5276 }
5277 }
78ca652e 5278
b9f751c0 5279 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
213aa87d 5280 doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 5281 op_append_elem(OP_LIST, term,
78ca652e 5282 scalar(newUNOP(OP_RV2CV, 0,
213aa87d 5283 newGVOP(OP_GV, 0, gv)))));
78ca652e
GS		 5284 }
5285 else {
5286 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5287 }
5288 return doop;
5289}
5290
d67eb5f4
Z		 5291/*
5292=head1 Optree construction
5293
5294=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5295
5296Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5297gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5298be set automatically, and, shifted up eight bits, the eight bits of
5299C<op_private>, except that the bit with value 1 or 2 is automatically
5300set as required. I<listval> and I<subscript> supply the parameters of
5301the slice; they are consumed by this function and become part of the
5302constructed op tree.
5303
5304=cut
5305*/
5306
78ca652e 5307OP *
864dbfa3 5308Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 5309{
5310 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 5311 list(force_list(subscript)),
5312 list(force_list(listval)) );
79072805
LW		 5313}
5314
76e3520e 5315STATIC I32
504618e9 5316S_is_list_assignment(pTHX_ register const OP *o)
79072805 5317{
1496a290
AL		 5318 unsigned type;
5319 U8 flags;
5320
11343788 5321 if (!o)
79072805
LW		 5322 return TRUE;
5323
1496a290 5324 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
11343788 5325 o = cUNOPo->op_first;
79072805 5326
1496a290
AL		 5327 flags = o->op_flags;
5328 type = o->op_type;
5329 if (type == OP_COND_EXPR) {
504618e9
AL		 5330 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5331 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 5332
5333 if (t && f)
5334 return TRUE;
5335 if (t || f)
5336 yyerror("Assignment to both a list and a scalar");
5337 return FALSE;
5338 }
5339
1496a290
AL		 5340 if (type == OP_LIST &&
5341 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
95f0a2f1
SB		 5342 o->op_private & OPpLVAL_INTRO)
5343 return FALSE;
5344
1496a290
AL		 5345 if (type == OP_LIST || flags & OPf_PARENS ||
5346 type == OP_RV2AV || type == OP_RV2HV ||
5347 type == OP_ASLICE || type == OP_HSLICE)
79072805
LW		 5348 return TRUE;
5349
1496a290 5350 if (type == OP_PADAV || type == OP_PADHV)
93a17b20
LW		 5351 return TRUE;
5352
1496a290 5353 if (type == OP_RV2SV)
79072805
LW		 5354 return FALSE;
5355
5356 return FALSE;
5357}
5358
d67eb5f4 5359/*
83f9fced
GG		 5360 Helper function for newASSIGNOP to detection commonality between the
5361 lhs and the rhs. Marks all variables with PL_generation. If it
5362 returns TRUE the assignment must be able to handle common variables.
5363*/
5364PERL_STATIC_INLINE bool
5365S_aassign_common_vars(pTHX_ OP* o)
5366{
83f9fced 5367 OP *curop;
3023b5f3 5368 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
83f9fced
GG		 5369 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5370 if (curop->op_type == OP_GV) {
5371 GV *gv = cGVOPx_gv(curop);
5372 if (gv == PL_defgv
5373 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5374 return TRUE;
5375 GvASSIGN_GENERATION_set(gv, PL_generation);
5376 }
5377 else if (curop->op_type == OP_PADSV ||
5378 curop->op_type == OP_PADAV ||
5379 curop->op_type == OP_PADHV ||
5380 curop->op_type == OP_PADANY)
5381 {
5382 if (PAD_COMPNAME_GEN(curop->op_targ)
5383 == (STRLEN)PL_generation)
5384 return TRUE;
5385 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5386
5387 }
5388 else if (curop->op_type == OP_RV2CV)
5389 return TRUE;
5390 else if (curop->op_type == OP_RV2SV ||
5391 curop->op_type == OP_RV2AV ||
5392 curop->op_type == OP_RV2HV ||
5393 curop->op_type == OP_RV2GV) {
3023b5f3 5394 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
83f9fced
GG		 5395 return TRUE;
5396 }
5397 else if (curop->op_type == OP_PUSHRE) {
5398#ifdef USE_ITHREADS
5399 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
5400 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
5401 if (gv == PL_defgv
5402 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5403 return TRUE;
5404 GvASSIGN_GENERATION_set(gv, PL_generation);
5405 }
5406#else
5407 GV *const gv
5408 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5409 if (gv) {
5410 if (gv == PL_defgv
5411 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5412 return TRUE;
5413 GvASSIGN_GENERATION_set(gv, PL_generation);
5414 }
5415#endif
5416 }
5417 else
5418 return TRUE;
5419 }
3023b5f3
GG		 5420
5421 if (curop->op_flags & OPf_KIDS) {
5422 if (aassign_common_vars(curop))
5423 return TRUE;
5424 }
83f9fced
GG		 5425 }
5426 return FALSE;
5427}
5428
5429/*
d67eb5f4
Z		 5430=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5431
5432Constructs, checks, and returns an assignment op. I<left> and I<right>
5433supply the parameters of the assignment; they are consumed by this
5434function and become part of the constructed op tree.
5435
5436If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5437a suitable conditional optree is constructed. If I<optype> is the opcode
5438of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5439performs the binary operation and assigns the result to the left argument.
5440Either way, if I<optype> is non-zero then I<flags> has no effect.
5441
5442If I<optype> is zero, then a plain scalar or list assignment is
5443constructed. Which type of assignment it is is automatically determined.
5444I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5445will be set automatically, and, shifted up eight bits, the eight bits
5446of C<op_private>, except that the bit with value 1 or 2 is automatically
5447set as required.
5448
5449=cut
5450*/
5451
79072805 5452OP *
864dbfa3 5453Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 5454{
97aff369 5455 dVAR;
11343788 5456 OP *o;
79072805 5457
a0d0e21e 5458 if (optype) {
c963b151 5459 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e 5460 return newLOGOP(optype, 0,
3ad73efd 5461 op_lvalue(scalar(left), optype),
a0d0e21e
LW		 5462 newUNOP(OP_SASSIGN, 0, scalar(right)));
5463 }
5464 else {
5465 return newBINOP(optype, OPf_STACKED,
3ad73efd 5466 op_lvalue(scalar(left), optype), scalar(right));
a0d0e21e
LW		 5467 }
5468 }
5469
504618e9 5470 if (is_list_assignment(left)) {
6dbe9451
NC		 5471 static const char no_list_state[] = "Initialization of state variables"
5472 " in list context currently forbidden";
10c8fecd 5473 OP *curop;
fafafbaf 5474 bool maybe_common_vars = TRUE;
10c8fecd 5475
3280af22 5476 PL_modcount = 0;
3ad73efd 5477 left = op_lvalue(left, OP_AASSIGN);
10c8fecd
GS		 5478 curop = list(force_list(left));
5479 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 5480 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4 5481
fafafbaf
RD		 5482 if ((left->op_type == OP_LIST
5483 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5484 {
5485 OP* lop = ((LISTOP*)left)->op_first;
5486 maybe_common_vars = FALSE;
5487 while (lop) {
5488 if (lop->op_type == OP_PADSV ||
5489 lop->op_type == OP_PADAV ||
5490 lop->op_type == OP_PADHV ||
5491 lop->op_type == OP_PADANY) {
5492 if (!(lop->op_private & OPpLVAL_INTRO))
5493 maybe_common_vars = TRUE;
5494
5495 if (lop->op_private & OPpPAD_STATE) {
5496 if (left->op_private & OPpLVAL_INTRO) {
5497 /* Each variable in state($a, $b, $c) = ... */
5498 }
5499 else {
5500 /* Each state variable in
5501 (state $a, my $b, our $c, $d, undef) = ... */
5502 }
5503 yyerror(no_list_state);
5504 } else {
5505 /* Each my variable in
5506 (state $a, my $b, our $c, $d, undef) = ... */
5507 }
5508 } else if (lop->op_type == OP_UNDEF ||
5509 lop->op_type == OP_PUSHMARK) {
5510 /* undef may be interesting in
5511 (state $a, undef, state $c) */
5512 } else {
5513 /* Other ops in the list. */
5514 maybe_common_vars = TRUE;
5515 }
5516 lop = lop->op_sibling;
5517 }
5518 }
5519 else if ((left->op_private & OPpLVAL_INTRO)
5520 && ( left->op_type == OP_PADSV
5521 || left->op_type == OP_PADAV
5522 || left->op_type == OP_PADHV
5523 || left->op_type == OP_PADANY))
5524 {
0f907b96 5525 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
fafafbaf
RD		 5526 if (left->op_private & OPpPAD_STATE) {
5527 /* All single variable list context state assignments, hence
5528 state ($a) = ...
5529 (state $a) = ...
5530 state @a = ...
5531 state (@a) = ...
5532 (state @a) = ...
5533 state %a = ...
5534 state (%a) = ...
5535 (state %a) = ...
5536 */
5537 yyerror(no_list_state);
5538 }
5539 }
5540
dd2155a4
DM		 5541 /* PL_generation sorcery:
5542 * an assignment like ($a,$b) = ($c,$d) is easier than
5543 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5544 * To detect whether there are common vars, the global var
5545 * PL_generation is incremented for each assign op we compile.
5546 * Then, while compiling the assign op, we run through all the
5547 * variables on both sides of the assignment, setting a spare slot
5548 * in each of them to PL_generation. If any of them already have
5549 * that value, we know we've got commonality. We could use a
5550 * single bit marker, but then we'd have to make 2 passes, first
5551 * to clear the flag, then to test and set it. To find somewhere
931b58fb 5552 * to store these values, evil chicanery is done with SvUVX().
dd2155a4
DM		 5553 */
5554
fafafbaf 5555 if (maybe_common_vars) {
3280af22 5556 PL_generation++;
83f9fced 5557 if (aassign_common_vars(o))
10c8fecd 5558 o->op_private |= OPpASSIGN_COMMON;
3023b5f3 5559 LINKLIST(o);
461824dc 5560 }
9fdc7570 5561
e9cc17ba 5562 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
1496a290
AL		 5563 OP* tmpop = ((LISTOP*)right)->op_first;
5564 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
551405c4 5565 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 5566 if (left->op_type == OP_RV2AV &&
5567 !(left->op_private & OPpLVAL_INTRO) &&
11343788 5568 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 5569 {
5570 tmpop = ((UNOP*)left)->op_first;
20e98b0f
NC		 5571 if (tmpop->op_type == OP_GV
5572#ifdef USE_ITHREADS
5573 && !pm->op_pmreplrootu.op_pmtargetoff
5574#else
5575 && !pm->op_pmreplrootu.op_pmtargetgv
5576#endif
5577 ) {
971a9dd3 5578#ifdef USE_ITHREADS
20e98b0f
NC		 5579 pm->op_pmreplrootu.op_pmtargetoff
5580 = cPADOPx(tmpop)->op_padix;
971a9dd3
GS		 5581 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5582#else
20e98b0f 5583 pm->op_pmreplrootu.op_pmtargetgv
159b6efe 5584 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
a0714e2c 5585 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 5586#endif
c07a80fd 5587 pm->op_pmflags |= PMf_ONCE;
11343788 5588 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 5589 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 5590 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 5591 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 5592 op_free(o); /* blow off assign */
54310121 5593 right->op_flags &= ~OPf_WANT;
a5f75d66 5594 /* "I don't know and I don't care." */
c07a80fd 5595 return right;
5596 }
5597 }
5598 else {
e6438c1a 5599 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 5600 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5601 {
5602 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
b8de32d5 5603 if (SvIOK(sv) && SvIVX(sv) == 0)
3280af22 5604 sv_setiv(sv, PL_modcount+1);
c07a80fd 5605 }
5606 }
5607 }
5608 }
11343788 5609 return o;
79072805
LW		 5610 }
5611 if (!right)
5612 right = newOP(OP_UNDEF, 0);
5613 if (right->op_type == OP_READLINE) {
5614 right->op_flags |= OPf_STACKED;
3ad73efd
Z		 5615 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5616 scalar(right));
79072805 5617 }
a0d0e21e 5618 else {
11343788 5619 o = newBINOP(OP_SASSIGN, flags,
3ad73efd 5620 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
a0d0e21e 5621 }
11343788 5622 return o;
79072805
LW		 5623}
5624
d67eb5f4
Z		 5625/*
5626=for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5627
5628Constructs a state op (COP). The state op is normally a C<nextstate> op,
5629but will be a C<dbstate> op if debugging is enabled for currently-compiled
5630code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5631If I<label> is non-null, it supplies the name of a label to attach to
5632the state op; this function takes ownership of the memory pointed at by
5633I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5634for the state op.
5635
5636If I<o> is null, the state op is returned. Otherwise the state op is
5637combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5638is consumed by this function and becomes part of the returned op tree.
5639
5640=cut
5641*/
5642
79072805 5643OP *
864dbfa3 5644Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 5645{
27da23d5 5646 dVAR;
e1ec3a88 5647 const U32 seq = intro_my();
5db1eb8d 5648 const U32 utf8 = flags & SVf_UTF8;
79072805
LW		 5649 register COP *cop;
5650
5db1eb8d
BF		 5651 flags &= ~SVf_UTF8;
5652
b7dc083c 5653 NewOp(1101, cop, 1, COP);
57843af0 5654 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 5655 cop->op_type = OP_DBSTATE;
22c35a8c 5656 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 5657 }
5658 else {
5659 cop->op_type = OP_NEXTSTATE;
22c35a8c 5660 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 5661 }
eb160463 5662 cop->op_flags = (U8)flags;
623e6609 5663 CopHINTS_set(cop, PL_hints);
ff0cee69 5664#ifdef NATIVE_HINTS
5665 cop->op_private |= NATIVE_HINTS;
5666#endif
623e6609 5667 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 5668 cop->op_next = (OP*)cop;
5669
bbce6d69 5670 cop->cop_seq = seq;
72dc9ed5 5671 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
20439bc7 5672 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
dca6062a 5673 if (label) {
5db1eb8d
BF		 5674 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5675
dca6062a
NC		 5676 PL_hints |= HINT_BLOCK_SCOPE;
5677 /* It seems that we need to defer freeing this pointer, as other parts
5678 of the grammar end up wanting to copy it after this op has been
5679 created. */
5680 SAVEFREEPV(label);
dca6062a 5681 }
79072805 5682
53a7735b 5683 if (PL_parser && PL_parser->copline == NOLINE)
57843af0 5684 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 5685 else {
53a7735b
DM		 5686 CopLINE_set(cop, PL_parser->copline);
5687 if (PL_parser)
5688 PL_parser->copline = NOLINE;
79072805 5689 }
57843af0 5690#ifdef USE_ITHREADS
f4dd75d9 5691 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 5692#else
f4dd75d9 5693 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 5694#endif
11faa288 5695 CopSTASH_set(cop, PL_curstash);
79072805 5696
65269a95
TB		 5697 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5698 /* this line can have a breakpoint - store the cop in IV */
80a702cd
RGS		 5699 AV *av = CopFILEAVx(PL_curcop);
5700 if (av) {
5701 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5702 if (svp && *svp != &PL_sv_undef ) {
5703 (void)SvIOK_on(*svp);
5704 SvIV_set(*svp, PTR2IV(cop));
5705 }
1eb1540c 5706 }
93a17b20
LW		 5707 }
5708
f6f3a1fe
RGS		 5709 if (flags & OPf_SPECIAL)
5710 op_null((OP*)cop);
2fcb4757 5711 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 5712}
5713
d67eb5f4
Z		 5714/*
5715=for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5716
5717Constructs, checks, and returns a logical (flow control) op. I<type>
5718is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5719that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5720the eight bits of C<op_private>, except that the bit with value 1 is
5721automatically set. I<first> supplies the expression controlling the
5722flow, and I<other> supplies the side (alternate) chain of ops; they are
5723consumed by this function and become part of the constructed op tree.
5724
5725=cut
5726*/
bbce6d69 5727
79072805 5728OP *
864dbfa3 5729Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 5730{
27da23d5 5731 dVAR;
7918f24d
NC		 5732
5733 PERL_ARGS_ASSERT_NEWLOGOP;
5734
883ffac3
CS		 5735 return new_logop(type, flags, &first, &other);
5736}
5737
3bd495df 5738STATIC OP *
71c4dbc3
VP		 5739S_search_const(pTHX_ OP *o)
5740{
5741 PERL_ARGS_ASSERT_SEARCH_CONST;
5742
5743 switch (o->op_type) {
5744 case OP_CONST:
5745 return o;
5746 case OP_NULL:
5747 if (o->op_flags & OPf_KIDS)
5748 return search_const(cUNOPo->op_first);
5749 break;
5750 case OP_LEAVE:
5751 case OP_SCOPE:
5752 case OP_LINESEQ:
5753 {
5754 OP *kid;
5755 if (!(o->op_flags & OPf_KIDS))
5756 return NULL;
5757 kid = cLISTOPo->op_first;
5758 do {
5759 switch (kid->op_type) {
5760 case OP_ENTER:
5761 case OP_NULL:
5762 case OP_NEXTSTATE:
5763 kid = kid->op_sibling;
5764 break;
5765 default:
5766 if (kid != cLISTOPo->op_last)
5767 return NULL;
5768 goto last;
5769 }
5770 } while (kid);
5771 if (!kid)
5772 kid = cLISTOPo->op_last;
5773last:
5774 return search_const(kid);
5775 }
5776 }
5777
5778 return NULL;
5779}
5780
5781STATIC OP *
cea2e8a9 5782S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 5783{
27da23d5 5784 dVAR;
79072805 5785 LOGOP *logop;
11343788 5786 OP *o;
71c4dbc3
VP		 5787 OP *first;
5788 OP *other;
5789 OP *cstop = NULL;
edbe35ea 5790 int prepend_not = 0;
79072805 5791
7918f24d
NC		 5792 PERL_ARGS_ASSERT_NEW_LOGOP;
5793
71c4dbc3
VP		 5794 first = *firstp;
5795 other = *otherp;
5796
a0d0e21e
LW		 5797 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5798 return newBINOP(type, flags, scalar(first), scalar(other));
5799
e69777c1
GG		 5800 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5801
8990e307 5802 scalarboolean(first);
edbe35ea 5803 /* optimize AND and OR ops that have NOTs as children */
68726e16 5804 if (first->op_type == OP_NOT
b6214b80 5805 && (first->op_flags & OPf_KIDS)
edbe35ea
VP		 5806 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5807 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
b6214b80 5808 && !PL_madskills) {
79072805
LW		 5809 if (type == OP_AND || type == OP_OR) {
5810 if (type == OP_AND)
5811 type = OP_OR;
5812 else
5813 type = OP_AND;
07f3cdf5 5814 op_null(first);
edbe35ea 5815 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
07f3cdf5 5816 op_null(other);
edbe35ea
VP		 5817 prepend_not = 1; /* prepend a NOT op later */
5818 }
79072805
LW		 5819 }
5820 }
71c4dbc3
VP		 5821 /* search for a constant op that could let us fold the test */
5822 if ((cstop = search_const(first))) {
5823 if (cstop->op_private & OPpCONST_STRICT)
5824 no_bareword_allowed(cstop);
a2a5de95
NC		 5825 else if ((cstop->op_private & OPpCONST_BARE))
5826 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
71c4dbc3
VP		 5827 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5828 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5829 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5f66b61c 5830 *firstp = NULL;
d6fee5c7
DM		 5831 if (other->op_type == OP_CONST)
5832 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 5833 if (PL_madskills) {
5834 OP *newop = newUNOP(OP_NULL, 0, other);
5835 op_getmad(first, newop, '1');
5836 newop->op_targ = type; /* set "was" field */
5837 return newop;
5838 }
5839 op_free(first);
dd3e51dc
VP		 5840 if (other->op_type == OP_LEAVE)
5841 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
2474a784
FC		 5842 else if (other->op_type == OP_MATCH
5843 || other->op_type == OP_SUBST
bb16bae8 5844 || other->op_type == OP_TRANSR
2474a784
FC		 5845 || other->op_type == OP_TRANS)
5846 /* Mark the op as being unbindable with =~ */
5847 other->op_flags |= OPf_SPECIAL;
79072805
LW		 5848 return other;
5849 }
5850 else {
7921d0f2 5851 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 5852 const OP *o2 = other;
7921d0f2
DM		 5853 if ( ! (o2->op_type == OP_LIST
5854 && (( o2 = cUNOPx(o2)->op_first))
5855 && o2->op_type == OP_PUSHMARK
5856 && (( o2 = o2->op_sibling)) )
5857 )
5858 o2 = other;
5859 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5860 || o2->op_type == OP_PADHV)
5861 && o2->op_private & OPpLVAL_INTRO
a2a5de95 5862 && !(o2->op_private & OPpPAD_STATE))
7921d0f2 5863 {
d1d15184
NC		 5864 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5865 "Deprecated use of my() in false conditional");
7921d0f2
DM		 5866 }
5867
5f66b61c 5868 *otherp = NULL;
d6fee5c7
DM		 5869 if (first->op_type == OP_CONST)
5870 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 5871 if (PL_madskills) {
5872 first = newUNOP(OP_NULL, 0, first);
5873 op_getmad(other, first, '2');
5874 first->op_targ = type; /* set "was" field */
5875 }
5876 else
5877 op_free(other);
79072805
LW		 5878 return first;
5879 }
5880 }
041457d9
DM		 5881 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5882 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 5883 {
b22e6366
AL		 5884 const OP * const k1 = ((UNOP*)first)->op_first;
5885 const OP * const k2 = k1->op_sibling;
a6006777 5886 OPCODE warnop = 0;
5887 switch (first->op_type)
5888 {
5889 case OP_NULL:
5890 if (k2 && k2->op_type == OP_READLINE
5891 && (k2->op_flags & OPf_STACKED)
1c846c1f 5892 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 5893 {
a6006777 5894 warnop = k2->op_type;
72b16652 5895 }
a6006777 5896 break;
5897
5898 case OP_SASSIGN:
68dc0745 5899 if (k1->op_type == OP_READDIR
5900 || k1->op_type == OP_GLOB
72b16652 5901 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 5902 || k1->op_type == OP_EACH
5903 || k1->op_type == OP_AEACH)
72b16652
GS		 5904 {
5905 warnop = ((k1->op_type == OP_NULL)
eb160463 5906 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 5907 }
a6006777 5908 break;
5909 }
8ebc5c01 5910 if (warnop) {
6867be6d 5911 const line_t oldline = CopLINE(PL_curcop);
53a7735b 5912 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 5913 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 5914 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 5915 PL_op_desc[warnop],
68dc0745 5916 ((warnop == OP_READLINE || warnop == OP_GLOB)
5917 ? " construct" : "() operator"));
57843af0 5918 CopLINE_set(PL_curcop, oldline);
8ebc5c01 5919 }
a6006777 5920 }
79072805
LW		 5921
5922 if (!other)
5923 return first;
5924
c963b151 5925 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 5926 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5927
b7dc083c 5928 NewOp(1101, logop, 1, LOGOP);
79072805 5929
eb160463 5930 logop->op_type = (OPCODE)type;
22c35a8c 5931 logop->op_ppaddr = PL_ppaddr[type];
79072805 5932 logop->op_first = first;
585ec06d 5933 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 5934 logop->op_other = LINKLIST(other);
eb160463 5935 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 5936
5937 /* establish postfix order */
5938 logop->op_next = LINKLIST(first);
5939 first->op_next = (OP*)logop;
5940 first->op_sibling = other;
5941
463d09e6
RGS		 5942 CHECKOP(type,logop);
5943
edbe35ea 5944 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
11343788 5945 other->op_next = o;
79072805 5946
11343788 5947 return o;
79072805
LW		 5948}
5949
d67eb5f4
Z		 5950/*
5951=for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5952
5953Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5954op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5955will be set automatically, and, shifted up eight bits, the eight bits of
5956C<op_private>, except that the bit with value 1 is automatically set.
5957I<first> supplies the expression selecting between the two branches,
5958and I<trueop> and I<falseop> supply the branches; they are consumed by
5959this function and become part of the constructed op tree.
5960
5961=cut
5962*/
5963
79072805 5964OP *
864dbfa3 5965Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 5966{
27da23d5 5967 dVAR;
1a67a97c
SM		 5968 LOGOP *logop;
5969 OP *start;
11343788 5970 OP *o;
71c4dbc3 5971 OP *cstop;
79072805 5972
7918f24d
NC		 5973 PERL_ARGS_ASSERT_NEWCONDOP;
5974
b1cb66bf 5975 if (!falseop)
5976 return newLOGOP(OP_AND, 0, first, trueop);
5977 if (!trueop)
5978 return newLOGOP(OP_OR, 0, first, falseop);
79072805 5979
8990e307 5980 scalarboolean(first);
71c4dbc3 5981 if ((cstop = search_const(first))) {
5b6782b2 5982 /* Left or right arm of the conditional? */
71c4dbc3 5983 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5b6782b2
NC		 5984 OP *live = left ? trueop : falseop;
5985 OP *const dead = left ? falseop : trueop;
71c4dbc3
VP		 5986 if (cstop->op_private & OPpCONST_BARE &&
5987 cstop->op_private & OPpCONST_STRICT) {
5988 no_bareword_allowed(cstop);
b22e6366 5989 }
5b6782b2
NC		 5990 if (PL_madskills) {
5991 /* This is all dead code when PERL_MAD is not defined. */
5992 live = newUNOP(OP_NULL, 0, live);
5993 op_getmad(first, live, 'C');
5994 op_getmad(dead, live, left ? 'e' : 't');
5995 } else {
5996 op_free(first);
5997 op_free(dead);
79072805 5998 }
ef9da979
FC		 5999 if (live->op_type == OP_LEAVE)
6000 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
2474a784 6001 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
bb16bae8 6002 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
2474a784
FC		 6003 /* Mark the op as being unbindable with =~ */
6004 live->op_flags |= OPf_SPECIAL;
5b6782b2 6005 return live;
79072805 6006 }
1a67a97c
SM		 6007 NewOp(1101, logop, 1, LOGOP);
6008 logop->op_type = OP_COND_EXPR;
6009 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6010 logop->op_first = first;
585ec06d 6011 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 6012 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 6013 logop->op_other = LINKLIST(trueop);
6014 logop->op_next = LINKLIST(falseop);
79072805 6015
463d09e6
RGS		 6016 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6017 logop);
79072805
LW		 6018
6019 /* establish postfix order */
1a67a97c
SM		 6020 start = LINKLIST(first);
6021 first->op_next = (OP*)logop;
79072805 6022
b1cb66bf 6023 first->op_sibling = trueop;
6024 trueop->op_sibling = falseop;
1a67a97c 6025 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 6026
1a67a97c 6027 trueop->op_next = falseop->op_next = o;
79072805 6028
1a67a97c 6029 o->op_next = start;
11343788 6030 return o;
79072805
LW		 6031}
6032
d67eb5f4
Z		 6033/*
6034=for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6035
6036Constructs and returns a C<range> op, with subordinate C<flip> and
6037C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6038C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6039for both the C<flip> and C<range> ops, except that the bit with value
60401 is automatically set. I<left> and I<right> supply the expressions
6041controlling the endpoints of the range; they are consumed by this function
6042and become part of the constructed op tree.
6043
6044=cut
6045*/
6046
79072805 6047OP *
864dbfa3 6048Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 6049{
27da23d5 6050 dVAR;
1a67a97c 6051 LOGOP *range;
79072805
LW		 6052 OP *flip;
6053 OP *flop;
1a67a97c 6054 OP *leftstart;
11343788 6055 OP *o;
79072805 6056
7918f24d
NC		 6057 PERL_ARGS_ASSERT_NEWRANGE;
6058
1a67a97c 6059 NewOp(1101, range, 1, LOGOP);
79072805 6060
1a67a97c
SM		 6061 range->op_type = OP_RANGE;
6062 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6063 range->op_first = left;
6064 range->op_flags = OPf_KIDS;
6065 leftstart = LINKLIST(left);
6066 range->op_other = LINKLIST(right);
eb160463 6067 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 6068
6069 left->op_sibling = right;
6070
1a67a97c
SM		 6071 range->op_next = (OP*)range;
6072 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 6073 flop = newUNOP(OP_FLOP, 0, flip);
11343788 6074 o = newUNOP(OP_NULL, 0, flop);
5983a79d 6075 LINKLIST(flop);
1a67a97c 6076 range->op_next = leftstart;
79072805
LW		 6077
6078 left->op_next = flip;
6079 right->op_next = flop;
6080
1a67a97c
SM		 6081 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6082 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 6083 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 6084 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6085
6086 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6087 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6088
eb796c7f
GG		 6089 /* check barewords before they might be optimized aways */
6090 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6091 no_bareword_allowed(left);
6092 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6093 no_bareword_allowed(right);
6094
11343788 6095 flip->op_next = o;
79072805 6096 if (!flip->op_private || !flop->op_private)
5983a79d 6097 LINKLIST(o); /* blow off optimizer unless constant */
79072805 6098
11343788 6099 return o;
79072805
LW		 6100}
6101
d67eb5f4
Z		 6102/*
6103=for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6104
6105Constructs, checks, and returns an op tree expressing a loop. This is
6106only a loop in the control flow through the op tree; it does not have
6107the heavyweight loop structure that allows exiting the loop by C<last>
6108and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6109top-level op, except that some bits will be set automatically as required.
6110I<expr> supplies the expression controlling loop iteration, and I<block>
6111supplies the body of the loop; they are consumed by this function and
6112become part of the constructed op tree. I<debuggable> is currently
6113unused and should always be 1.
6114
6115=cut
6116*/
6117
79072805 6118OP *
864dbfa3 6119Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 6120{
97aff369 6121 dVAR;
463ee0b2 6122 OP* listop;
11343788 6123 OP* o;
73d840c0 6124 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 6125 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 6126
6127 PERL_UNUSED_ARG(debuggable);
93a17b20 6128
463ee0b2
LW		 6129 if (expr) {
6130 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6131 return block; /* do {} while 0 does once */
114c60ec
BG		 6132 if (expr->op_type == OP_READLINE
6133 || expr->op_type == OP_READDIR
6134 || expr->op_type == OP_GLOB
8ae39f60 6135 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
fb73857a 6136 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 6137 expr = newUNOP(OP_DEFINED, 0,
54b9620d 6138 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 6139 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 6140 const OP * const k1 = ((UNOP*)expr)->op_first;
6141 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 6142 switch (expr->op_type) {
1c846c1f 6143 case OP_NULL:
114c60ec 6144 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
55d729e4 6145 && (k2->op_flags & OPf_STACKED)
1c846c1f 6146 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 6147 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 6148 break;
55d729e4
GS		 6149
6150 case OP_SASSIGN:
06dc7ac6 6151 if (k1 && (k1->op_type == OP_READDIR
55d729e4 6152 || k1->op_type == OP_GLOB
6531c3e6 6153 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 6154 || k1->op_type == OP_EACH
6155 || k1->op_type == OP_AEACH))
55d729e4
GS		 6156 expr = newUNOP(OP_DEFINED, 0, expr);
6157 break;
6158 }
774d564b 6159 }
463ee0b2 6160 }
93a17b20 6161
2fcb4757 6162 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
e1548254
RGS		 6163 * op, in listop. This is wrong. [perl #27024] */
6164 if (!block)
6165 block = newOP(OP_NULL, 0);
2fcb4757 6166 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 6167 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 6168
883ffac3
CS		 6169 if (listop)
6170 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 6171
11343788
MB		 6172 if (once && o != listop)
6173 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 6174
11343788
MB		 6175 if (o == listop)
6176 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 6177
11343788 6178 o->op_flags |= flags;
3ad73efd 6179 o = op_scope(o);
11343788
MB		 6180 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6181 return o;
79072805
LW		 6182}
6183
d67eb5f4 6184/*
94bf0465 6185=for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
d67eb5f4
Z		 6186
6187Constructs, checks, and returns an op tree expressing a C<while> loop.
6188This is a heavyweight loop, with structure that allows exiting the loop
6189by C<last> and suchlike.
6190
6191I<loop> is an optional preconstructed C<enterloop> op to use in the
6192loop; if it is null then a suitable op will be constructed automatically.
6193I<expr> supplies the loop's controlling expression. I<block> supplies the
6194main body of the loop, and I<cont> optionally supplies a C<continue> block
6195that operates as a second half of the body. All of these optree inputs
6196are consumed by this function and become part of the constructed op tree.
6197
6198I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6199op and, shifted up eight bits, the eight bits of C<op_private> for
6200the C<leaveloop> op, except that (in both cases) some bits will be set
6201automatically. I<debuggable> is currently unused and should always be 1.
94bf0465 6202I<has_my> can be supplied as true to force the
d67eb5f4
Z		 6203loop body to be enclosed in its own scope.
6204
6205=cut
6206*/
6207
79072805 6208OP *
94bf0465
Z		 6209Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6210 OP *expr, OP *block, OP *cont, I32 has_my)
79072805 6211{
27da23d5 6212 dVAR;
79072805 6213 OP *redo;
c445ea15 6214 OP *next = NULL;
79072805 6215 OP *listop;
11343788 6216 OP *o;
1ba6ee2b 6217 U8 loopflags = 0;
46c461b5
AL		 6218
6219 PERL_UNUSED_ARG(debuggable);
79072805 6220
2d03de9c 6221 if (expr) {
114c60ec
BG		 6222 if (expr->op_type == OP_READLINE
6223 || expr->op_type == OP_READDIR
6224 || expr->op_type == OP_GLOB
8ae39f60 6225 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
2d03de9c
AL		 6226 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6227 expr = newUNOP(OP_DEFINED, 0,
6228 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6229 } else if (expr->op_flags & OPf_KIDS) {
6230 const OP * const k1 = ((UNOP*)expr)->op_first;
6231 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6232 switch (expr->op_type) {
6233 case OP_NULL:
114c60ec 6234 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
2d03de9c
AL		 6235 && (k2->op_flags & OPf_STACKED)
6236 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6237 expr = newUNOP(OP_DEFINED, 0, expr);
6238 break;
55d729e4 6239
2d03de9c 6240 case OP_SASSIGN:
72c8de1a 6241 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 6242 || k1->op_type == OP_GLOB
6243 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 6244 || k1->op_type == OP_EACH
6245 || k1->op_type == OP_AEACH))
2d03de9c
AL		 6246 expr = newUNOP(OP_DEFINED, 0, expr);
6247 break;
6248 }
55d729e4 6249 }
748a9306 6250 }
79072805
LW		 6251
6252 if (!block)
6253 block = newOP(OP_NULL, 0);
a034e688 6254 else if (cont || has_my) {
3ad73efd 6255 block = op_scope(block);
87246558 6256 }
79072805 6257
1ba6ee2b 6258 if (cont) {
79072805 6259 next = LINKLIST(cont);
1ba6ee2b 6260 }
fb73857a 6261 if (expr) {
551405c4 6262 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 6263 if (!next)
6264 next = unstack;
2fcb4757 6265 cont = op_append_elem(OP_LINESEQ, cont, unstack);
fb73857a 6266 }
79072805 6267
ce3e5c45 6268 assert(block);
2fcb4757 6269 listop = op_append_list(OP_LINESEQ, block, cont);
ce3e5c45 6270 assert(listop);
79072805
LW		 6271 redo = LINKLIST(listop);
6272
6273 if (expr) {
883ffac3
CS		 6274 scalar(listop);
6275 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 6276 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 6277 op_free(expr); /* oops, it's a while (0) */
463ee0b2 6278 op_free((OP*)loop);
5f66b61c 6279 return NULL; /* listop already freed by new_logop */
463ee0b2 6280 }
883ffac3 6281 if (listop)
497b47a8 6282 ((LISTOP*)listop)->op_last->op_next =
883ffac3 6283 (o == listop ? redo : LINKLIST(o));
79072805
LW		 6284 }
6285 else
11343788 6286 o = listop;
79072805
LW		 6287
6288 if (!loop) {
b7dc083c 6289 NewOp(1101,loop,1,LOOP);
79072805 6290 loop->op_type = OP_ENTERLOOP;
22c35a8c 6291 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 6292 loop->op_private = 0;
6293 loop->op_next = (OP*)loop;
6294 }
6295
11343788 6296 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 6297
6298 loop->op_redoop = redo;
11343788 6299 loop->op_lastop = o;
1ba6ee2b 6300 o->op_private |= loopflags;
79072805
LW		 6301
6302 if (next)
6303 loop->op_nextop = next;
6304 else
11343788 6305 loop->op_nextop = o;
79072805 6306
11343788
MB		 6307 o->op_flags |= flags;
6308 o->op_private |= (flags >> 8);
6309 return o;
79072805
LW		 6310}
6311
d67eb5f4 6312/*
94bf0465 6313=for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
d67eb5f4
Z		 6314
6315Constructs, checks, and returns an op tree expressing a C<foreach>
6316loop (iteration through a list of values). This is a heavyweight loop,
6317with structure that allows exiting the loop by C<last> and suchlike.
6318
6319I<sv> optionally supplies the variable that will be aliased to each
6320item in turn; if null, it defaults to C<$_> (either lexical or global).
6321I<expr> supplies the list of values to iterate over. I<block> supplies
6322the main body of the loop, and I<cont> optionally supplies a C<continue>
6323block that operates as a second half of the body. All of these optree
6324inputs are consumed by this function and become part of the constructed
6325op tree.
6326
6327I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6328op and, shifted up eight bits, the eight bits of C<op_private> for
6329the C<leaveloop> op, except that (in both cases) some bits will be set
94bf0465 6330automatically.
d67eb5f4
Z		 6331
6332=cut
6333*/
6334
79072805 6335OP *
94bf0465 6336Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
79072805 6337{
27da23d5 6338 dVAR;
79072805 6339 LOOP *loop;
fb73857a 6340 OP *wop;
4bbc6d12 6341 PADOFFSET padoff = 0;
4633a7c4 6342 I32 iterflags = 0;
241416b8 6343 I32 iterpflags = 0;
d4c19fe8 6344 OP *madsv = NULL;
79072805 6345
7918f24d
NC		 6346 PERL_ARGS_ASSERT_NEWFOROP;
6347
79072805 6348 if (sv) {
85e6fe83 6349 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 6350 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 6351 sv->op_type = OP_RV2GV;
22c35a8c 6352 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0be9a6bb
RH		 6353
6354 /* The op_type check is needed to prevent a possible segfault
6355 * if the loop variable is undeclared and 'strict vars' is in
6356 * effect. This is illegal but is nonetheless parsed, so we
6357 * may reach this point with an OP_CONST where we're expecting
6358 * an OP_GV.
6359 */
6360 if (cUNOPx(sv)->op_first->op_type == OP_GV
6361 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
0d863452 6362 iterpflags |= OPpITER_DEF;
79072805 6363 }
85e6fe83 6364 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 6365 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 6366 padoff = sv->op_targ;
eb8433b7
NC		 6367 if (PL_madskills)
6368 madsv = sv;
6369 else {
6370 sv->op_targ = 0;
6371 op_free(sv);
6372 }
5f66b61c 6373 sv = NULL;
85e6fe83 6374 }
79072805 6375 else
cea2e8a9 6376 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
f8503592
NC		 6377 if (padoff) {
6378 SV *const namesv = PAD_COMPNAME_SV(padoff);
6379 STRLEN len;
6380 const char *const name = SvPV_const(namesv, len);
6381
6382 if (len == 2 && name[0] == '$' && name[1] == '_')
6383 iterpflags |= OPpITER_DEF;
6384 }
79072805
LW		 6385 }
6386 else {
cc76b5cc 6387 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 6388 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 6389 sv = newGVOP(OP_GV, 0, PL_defgv);
6390 }
6391 else {
6392 padoff = offset;
aabe9514 6393 }
0d863452 6394 iterpflags |= OPpITER_DEF;
79072805 6395 }
5f05dabc 6396 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3ad73efd 6397 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 6398 iterflags |= OPf_STACKED;
6399 }
89ea2908
GA		 6400 else if (expr->op_type == OP_NULL &&
6401 (expr->op_flags & OPf_KIDS) &&
6402 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6403 {
6404 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6405 * set the STACKED flag to indicate that these values are to be
6406 * treated as min/max values by 'pp_iterinit'.
6407 */
d4c19fe8 6408 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 6409 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 6410 OP* const left = range->op_first;
6411 OP* const right = left->op_sibling;
5152d7c7 6412 LISTOP* listop;
89ea2908
GA		 6413
6414 range->op_flags &= ~OPf_KIDS;
5f66b61c 6415 range->op_first = NULL;
89ea2908 6416
5152d7c7 6417 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 6418 listop->op_first->op_next = range->op_next;
6419 left->op_next = range->op_other;
5152d7c7
GS		 6420 right->op_next = (OP*)listop;
6421 listop->op_next = listop->op_first;
89ea2908 6422
eb8433b7
NC		 6423#ifdef PERL_MAD
6424 op_getmad(expr,(OP*)listop,'O');
6425#else
89ea2908 6426 op_free(expr);
eb8433b7 6427#endif
5152d7c7 6428 expr = (OP*)(listop);
93c66552 6429 op_null(expr);
89ea2908
GA		 6430 iterflags |= OPf_STACKED;
6431 }
6432 else {
3ad73efd 6433 expr = op_lvalue(force_list(expr), OP_GREPSTART);
89ea2908
GA		 6434 }
6435
4633a7c4 6436 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
2fcb4757 6437 op_append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 6438 assert(!loop->op_next);
241416b8 6439 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 6440 * for our $x () sets OPpOUR_INTRO */
c5661c80 6441 loop->op_private = (U8)iterpflags;
8be227ab
FC		 6442#ifndef PL_OP_SLAB_ALLOC
6443 if (DIFF(loop, OpSLOT(loop)->opslot_next)
6444 < SIZE_TO_PSIZE(sizeof(LOOP)))
6445#endif
155aba94
GS		 6446 {
6447 LOOP *tmp;
6448 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 6449 Copy(loop,tmp,1,LISTOP);
bfafaa29 6450 S_op_destroy(aTHX_ (OP*)loop);
155aba94
GS		 6451 loop = tmp;
6452 }
85e6fe83 6453 loop->op_targ = padoff;
94bf0465 6454 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 6455 if (madsv)
6456 op_getmad(madsv, (OP*)loop, 'v');
eae48c89 6457 return wop;
79072805
LW		 6458}
6459
d67eb5f4
Z		 6460/*
6461=for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6462
6463Constructs, checks, and returns a loop-exiting op (such as C<goto>
6464or C<last>). I<type> is the opcode. I<label> supplies the parameter
6465determining the target of the op; it is consumed by this function and
6466become part of the constructed op tree.
6467
6468=cut
6469*/
6470
8990e307 6471OP*
864dbfa3 6472Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 6473{
97aff369 6474 dVAR;
11343788 6475 OP *o;
2d8e6c8d 6476
7918f24d
NC		 6477 PERL_ARGS_ASSERT_NEWLOOPEX;
6478
e69777c1
GG		 6479 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6480
3532f34a 6481 if (type != OP_GOTO) {
cdaebead
MB		 6482 /* "last()" means "last" */
6483 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6484 o = newOP(type, OPf_SPECIAL);
6485 else {
3532f34a 6486 const_label:
5db1eb8d
BF		 6487 o = newPVOP(type,
6488 label->op_type == OP_CONST
6489 ? SvUTF8(((SVOP*)label)->op_sv)
6490 : 0,
6491 savesharedpv(label->op_type == OP_CONST
6492 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6493 : ""));
cdaebead 6494 }
eb8433b7
NC		 6495#ifdef PERL_MAD
6496 op_getmad(label,o,'L');
6497#else
8990e307 6498 op_free(label);
eb8433b7 6499#endif
8990e307
LW		 6500 }
6501 else {
e3aba57a
RGS		 6502 /* Check whether it's going to be a goto &function */
6503 if (label->op_type == OP_ENTERSUB
6504 && !(label->op_flags & OPf_STACKED))
3ad73efd 6505 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
3532f34a
FC		 6506 else if (label->op_type == OP_CONST) {
6507 SV * const sv = ((SVOP *)label)->op_sv;
6508 STRLEN l;
6509 const char *s = SvPV_const(sv,l);
6510 if (l == strlen(s)) goto const_label;
6511 }
11343788 6512 o = newUNOP(type, OPf_STACKED, label);
8990e307 6513 }
3280af22 6514 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6515 return o;
8990e307
LW		 6516}
6517
0d863452
RH		 6518/* if the condition is a literal array or hash
6519 (or @{ ... } etc), make a reference to it.
6520 */
6521STATIC OP *
6522S_ref_array_or_hash(pTHX_ OP *cond)
6523{
6524 if (cond
6525 && (cond->op_type == OP_RV2AV
6526 || cond->op_type == OP_PADAV
6527 || cond->op_type == OP_RV2HV
6528 || cond->op_type == OP_PADHV))
6529
3ad73efd 6530 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
0d863452 6531
329a333e
DL		 6532 else if(cond
6533 && (cond->op_type == OP_ASLICE
6534 || cond->op_type == OP_HSLICE)) {
6535
6536 /* anonlist now needs a list from this op, was previously used in
6537 * scalar context */
6538 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6539 cond->op_flags |= OPf_WANT_LIST;
6540
3ad73efd 6541 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
329a333e
DL		 6542 }
6543
0d863452
RH		 6544 else
6545 return cond;
6546}
6547
6548/* These construct the optree fragments representing given()
6549 and when() blocks.
6550
6551 entergiven and enterwhen are LOGOPs; the op_other pointer
6552 points up to the associated leave op. We need this so we
6553 can put it in the context and make break/continue work.
6554 (Also, of course, pp_enterwhen will jump straight to
6555 op_other if the match fails.)
6556 */
6557
4136a0f7 6558STATIC OP *
0d863452
RH		 6559S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6560 I32 enter_opcode, I32 leave_opcode,
6561 PADOFFSET entertarg)
6562{
97aff369 6563 dVAR;
0d863452
RH		 6564 LOGOP *enterop;
6565 OP *o;
6566
7918f24d
NC		 6567 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6568
0d863452 6569 NewOp(1101, enterop, 1, LOGOP);
61a59f30 6570 enterop->op_type = (Optype)enter_opcode;
0d863452
RH		 6571 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6572 enterop->op_flags = (U8) OPf_KIDS;
6573 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6574 enterop->op_private = 0;
6575
6576 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6577
6578 if (cond) {
6579 enterop->op_first = scalar(cond);
6580 cond->op_sibling = block;
6581
6582 o->op_next = LINKLIST(cond);
6583 cond->op_next = (OP *) enterop;
6584 }
6585 else {
6586 /* This is a default {} block */
6587 enterop->op_first = block;
6588 enterop->op_flags |= OPf_SPECIAL;
fc7debfb 6589 o ->op_flags |= OPf_SPECIAL;
0d863452
RH		 6590
6591 o->op_next = (OP *) enterop;
6592 }
6593
6594 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6595 entergiven and enterwhen both
6596 use ck_null() */
6597
6598 enterop->op_next = LINKLIST(block);
6599 block->op_next = enterop->op_other = o;
6600
6601 return o;
6602}
6603
6604/* Does this look like a boolean operation? For these purposes
6605 a boolean operation is:
6606 - a subroutine call [*]
6607 - a logical connective
6608 - a comparison operator
6609 - a filetest operator, with the exception of -s -M -A -C
6610 - defined(), exists() or eof()
6611 - /$re/ or $foo =~ /$re/
6612
6613 [*] possibly surprising
6614 */
4136a0f7 6615STATIC bool
ef519e13 6616S_looks_like_bool(pTHX_ const OP *o)
0d863452 6617{
97aff369 6618 dVAR;
7918f24d
NC		 6619
6620 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6621
0d863452
RH		 6622 switch(o->op_type) {
6623 case OP_OR:
f92e1a16 6624 case OP_DOR:
0d863452
RH		 6625 return looks_like_bool(cLOGOPo->op_first);
6626
6627 case OP_AND:
6628 return (
6629 looks_like_bool(cLOGOPo->op_first)
6630 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6631
1e1d4b91 6632 case OP_NULL:
08fe1c44 6633 case OP_SCALAR:
1e1d4b91
JJ		 6634 return (
6635 o->op_flags & OPf_KIDS
6636 && looks_like_bool(cUNOPo->op_first));
6637
0d863452
RH		 6638 case OP_ENTERSUB:
6639
6640 case OP_NOT: case OP_XOR:
0d863452
RH		 6641
6642 case OP_EQ: case OP_NE: case OP_LT:
6643 case OP_GT: case OP_LE: case OP_GE:
6644
6645 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6646 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6647
6648 case OP_SEQ: case OP_SNE: case OP_SLT:
6649 case OP_SGT: case OP_SLE: case OP_SGE:
6650
6651 case OP_SMARTMATCH:
6652
6653 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6654 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6655 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6656 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6657 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6658 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6659 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6660 case OP_FTTEXT: case OP_FTBINARY:
6661
6662 case OP_DEFINED: case OP_EXISTS:
6663 case OP_MATCH: case OP_EOF:
6664
f118ea0d
RGS		 6665 case OP_FLOP:
6666
0d863452
RH		 6667 return TRUE;
6668
6669 case OP_CONST:
6670 /* Detect comparisons that have been optimized away */
6671 if (cSVOPo->op_sv == &PL_sv_yes
6672 || cSVOPo->op_sv == &PL_sv_no)
6673
6674 return TRUE;
6e03d743
RGS		 6675 else
6676 return FALSE;
6e03d743 6677
0d863452
RH		 6678 /* FALL THROUGH */
6679 default:
6680 return FALSE;
6681 }
6682}
6683
d67eb5f4
Z		 6684/*
6685=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6686
6687Constructs, checks, and returns an op tree expressing a C<given> block.
6688I<cond> supplies the expression that will be locally assigned to a lexical
6689variable, and I<block> supplies the body of the C<given> construct; they
6690are consumed by this function and become part of the constructed op tree.
6691I<defsv_off> is the pad offset of the scalar lexical variable that will
6692be affected.
6693
6694=cut
6695*/
6696
0d863452
RH		 6697OP *
6698Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6699{
97aff369 6700 dVAR;
7918f24d 6701 PERL_ARGS_ASSERT_NEWGIVENOP;
0d863452
RH		 6702 return newGIVWHENOP(
6703 ref_array_or_hash(cond),
6704 block,
6705 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6706 defsv_off);
6707}
6708
d67eb5f4
Z		 6709/*
6710=for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6711
6712Constructs, checks, and returns an op tree expressing a C<when> block.
6713I<cond> supplies the test expression, and I<block> supplies the block
6714that will be executed if the test evaluates to true; they are consumed
6715by this function and become part of the constructed op tree. I<cond>
6716will be interpreted DWIMically, often as a comparison against C<$_>,
6717and may be null to generate a C<default> block.
6718
6719=cut
6720*/
6721
0d863452
RH		 6722OP *
6723Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6724{
ef519e13 6725 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 6726 OP *cond_op;
6727
7918f24d
NC		 6728 PERL_ARGS_ASSERT_NEWWHENOP;
6729
0d863452
RH		 6730 if (cond_llb)
6731 cond_op = cond;
6732 else {
6733 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6734 newDEFSVOP(),
6735 scalar(ref_array_or_hash(cond)));
6736 }
6737
c08f093b 6738 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
0d863452
RH		 6739}
6740
3fe9a6f1 6741void
dab1c735
BF		 6742Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6743 const STRLEN len, const U32 flags)
cbf82dd0 6744{
8fa6a409
FC		 6745 const char * const cvp = CvPROTO(cv);
6746 const STRLEN clen = CvPROTOLEN(cv);
6747
dab1c735 6748 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
8fa6a409
FC		 6749
6750 if (((!p != !cvp) /* One has prototype, one has not. */
6751 || (p && (
6752 (flags & SVf_UTF8) == SvUTF8(cv)
6753 ? len != clen || memNE(cvp, p, len)
6754 : flags & SVf_UTF8
6755 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6756 (const U8 *)p, len)
6757 : bytes_cmp_utf8((const U8 *)p, len,
6758 (const U8 *)cvp, clen)
6759 )
6760 )
6761 )
cbf82dd0 6762 && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 6763 SV* const msg = sv_newmortal();
a0714e2c 6764 SV* name = NULL;
3fe9a6f1 6765
6766 if (gv)
bd61b366 6767 gv_efullname3(name = sv_newmortal(), gv, NULL);
6502358f 6768 sv_setpvs(msg, "Prototype mismatch:");
46fc3d4c 6769 if (name)
be2597df 6770 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
3fe9a6f1 6771 if (SvPOK(cv))
8fa6a409
FC		 6772 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6773 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6774 );
ebe643b9 6775 else
396482e1
GA		 6776 sv_catpvs(msg, ": none");
6777 sv_catpvs(msg, " vs ");
46fc3d4c 6778 if (p)
dab1c735 6779 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
46fc3d4c 6780 else
396482e1 6781 sv_catpvs(msg, "none");
be2597df 6782 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 6783 }
6784}
6785
35f1c1c7
SB		 6786static void const_sv_xsub(pTHX_ CV* cv);
6787
beab0874 6788/*
ccfc67b7
JH		 6789
6790=head1 Optree Manipulation Functions
6791
beab0874
JT		 6792=for apidoc cv_const_sv
6793
6794If C<cv> is a constant sub eligible for inlining. returns the constant
6795value returned by the sub. Otherwise, returns NULL.
6796
6797Constant subs can be created with C<newCONSTSUB> or as described in
6798L<perlsub/"Constant Functions">.
6799
6800=cut
6801*/
760ac839 6802SV *
d45f5b30 6803Perl_cv_const_sv(pTHX_ const CV *const cv)
760ac839 6804{
96a5add6 6805 PERL_UNUSED_CONTEXT;
5069cc75
NC		 6806 if (!cv)
6807 return NULL;
6808 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6809 return NULL;
ad64d0ec 6810 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
fe5e78ed 6811}
760ac839 6812
b5c19bd7
DM		 6813/* op_const_sv: examine an optree to determine whether it's in-lineable.
6814 * Can be called in 3 ways:
6815 *
6816 * !cv
6817 * look for a single OP_CONST with attached value: return the value
6818 *
6819 * cv && CvCLONE(cv) && !CvCONST(cv)
6820 *
6821 * examine the clone prototype, and if contains only a single
6822 * OP_CONST referencing a pad const, or a single PADSV referencing
6823 * an outer lexical, return a non-zero value to indicate the CV is
6824 * a candidate for "constizing" at clone time
6825 *
6826 * cv && CvCONST(cv)
6827 *
6828 * We have just cloned an anon prototype that was marked as a const
486ec47a 6829 * candidate. Try to grab the current value, and in the case of
b5c19bd7
DM		 6830 * PADSV, ignore it if it has multiple references. Return the value.
6831 */
6832
fe5e78ed 6833SV *
6867be6d 6834Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 6835{
97aff369 6836 dVAR;
a0714e2c 6837 SV *sv = NULL;
fe5e78ed 6838
c631f32b
GG		 6839 if (PL_madskills)
6840 return NULL;
6841
0f79a09d 6842 if (!o)
a0714e2c 6843 return NULL;
1c846c1f
NIS		 6844
6845 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 6846 o = cLISTOPo->op_first->op_sibling;
6847
6848 for (; o; o = o->op_next) {
890ce7af 6849 const OPCODE type = o->op_type;
fe5e78ed 6850
1c846c1f 6851 if (sv && o->op_next == o)
fe5e78ed 6852 return sv;
e576b457 6853 if (o->op_next != o) {
dbe92b04
FC		 6854 if (type == OP_NEXTSTATE
6855 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6856 || type == OP_PUSHMARK)
e576b457
JT		 6857 continue;
6858 if (type == OP_DBSTATE)
6859 continue;
6860 }
54310121 6861 if (type == OP_LEAVESUB || type == OP_RETURN)
6862 break;
6863 if (sv)
a0714e2c 6864 return NULL;
7766f137 6865 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 6866 sv = cSVOPo->op_sv;
b5c19bd7 6867 else if (cv && type == OP_CONST) {
dd2155a4 6868 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 6869 if (!sv)
a0714e2c 6870 return NULL;
b5c19bd7
DM		 6871 }
6872 else if (cv && type == OP_PADSV) {
6873 if (CvCONST(cv)) { /* newly cloned anon */
6874 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6875 /* the candidate should have 1 ref from this pad and 1 ref
6876 * from the parent */
6877 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 6878 return NULL;
beab0874 6879 sv = newSVsv(sv);
b5c19bd7
DM		 6880 SvREADONLY_on(sv);
6881 return sv;
6882 }
6883 else {
6884 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6885 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 6886 }
760ac839 6887 }
b5c19bd7 6888 else {
a0714e2c 6889 return NULL;
b5c19bd7 6890 }
760ac839
LW		 6891 }
6892 return sv;
6893}
6894
eb8433b7
NC		 6895#ifdef PERL_MAD
6896OP *
6897#else
09bef843 6898void
eb8433b7 6899#endif
09bef843
SB		 6900Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6901{
99129197
NC		 6902#if 0
6903 /* This would be the return value, but the return cannot be reached. */
eb8433b7
NC		 6904 OP* pegop = newOP(OP_NULL, 0);
6905#endif
6906
46c461b5
AL		 6907 PERL_UNUSED_ARG(floor);
6908
09bef843
SB		 6909 if (o)
6910 SAVEFREEOP(o);
6911 if (proto)
6912 SAVEFREEOP(proto);
6913 if (attrs)
6914 SAVEFREEOP(attrs);
6915 if (block)
6916 SAVEFREEOP(block);
6917 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
eb8433b7 6918#ifdef PERL_MAD
99129197 6919 NORETURN_FUNCTION_END;
eb8433b7 6920#endif
09bef843
SB		 6921}
6922
748a9306 6923CV *
09bef843
SB		 6924Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6925{
7e68c38b
FC		 6926 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
6927}
6928
6929CV *
6930Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
6931 OP *block, U32 flags)
6932{
27da23d5 6933 dVAR;
83ee9e09 6934 GV *gv;
5c144d81 6935 const char *ps;
52a9a866 6936 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
e0260a5b 6937 U32 ps_utf8 = 0;
c445ea15 6938 register CV *cv = NULL;
beab0874 6939 SV *const_sv;
a73ef99b 6940 const bool ec = PL_parser && PL_parser->error_count;
b48b272a
NC		 6941 /* If the subroutine has no body, no attributes, and no builtin attributes
6942 then it's just a sub declaration, and we may be able to get away with
6943 storing with a placeholder scalar in the symbol table, rather than a
6944 full GV and CV. If anything is present then it will take a full CV to
6945 store it. */
6946 const I32 gv_fetch_flags
a73ef99b
FC		 6947 = ec ? GV_NOADD_NOINIT :
6948 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
eb8433b7 6949 || PL_madskills)
b48b272a 6950 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6e948d54 6951 STRLEN namlen = 0;
7e68c38b
FC		 6952 const bool o_is_gv = flags & 1;
6953 const char * const name =
6954 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
ed4a8a9b 6955 bool has_name;
7e68c38b 6956 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8e742a20
MHM		 6957
6958 if (proto) {
6959 assert(proto->op_type == OP_CONST);
4ea561bc 6960 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
e0260a5b 6961 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8e742a20
MHM		 6962 }
6963 else
bd61b366 6964 ps = NULL;
8e742a20 6965
7e68c38b
FC		 6966 if (o_is_gv) {
6967 gv = (GV*)o;
6968 o = NULL;
6969 has_name = TRUE;
6970 } else if (name) {
6971 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
ed4a8a9b
NC		 6972 has_name = TRUE;
6973 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 6974 SV * const sv = sv_newmortal();
c99da370
JH		 6975 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6976 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 6977 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
ed4a8a9b
NC		 6978 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6979 has_name = TRUE;
c1754fce
NC		 6980 } else if (PL_curstash) {
6981 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 6982 has_name = FALSE;
c1754fce
NC		 6983 } else {
6984 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 6985 has_name = FALSE;
c1754fce 6986 }
83ee9e09 6987
eb8433b7
NC		 6988 if (!PL_madskills) {
6989 if (o)
6990 SAVEFREEOP(o);
6991 if (proto)
6992 SAVEFREEOP(proto);
6993 if (attrs)
6994 SAVEFREEOP(attrs);
6995 }
3fe9a6f1 6996
a73ef99b
FC		 6997 if (ec) {
6998 op_free(block);
6999 if (name && block) {
7000 const char *s = strrchr(name, ':');
7001 s = s ? s+1 : name;
7002 if (strEQ(s, "BEGIN")) {
7003 const char not_safe[] =
7004 "BEGIN not safe after errors--compilation aborted";
7005 if (PL_in_eval & EVAL_KEEPERR)
7006 Perl_croak(aTHX_ not_safe);
7007 else {
7008 /* force display of errors found but not reported */
7009 sv_catpv(ERRSV, not_safe);
7010 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
7011 }
7012 }
7013 }
7014 cv = PL_compcv;
7015 goto done;
7016 }
7017
09bef843 7018 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 7019 maximum a prototype before. */
7020 if (SvTYPE(gv) > SVt_NULL) {
dab1c735 7021 cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
55d729e4 7022 }
e0260a5b 7023 if (ps) {
ad64d0ec 7024 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
e0260a5b
BF		 7025 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7026 }
55d729e4 7027 else
ad64d0ec 7028 sv_setiv(MUTABLE_SV(gv), -1);
e1a479c5 7029
3280af22
NIS		 7030 SvREFCNT_dec(PL_compcv);
7031 cv = PL_compcv = NULL;
beab0874 7032 goto done;
55d729e4
GS		 7033 }
7034
601f1833 7035 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 7036
eb8433b7
NC		 7037 if (!block || !ps || *ps || attrs
7038 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7039#ifdef PERL_MAD
7040 || block->op_type == OP_NULL
7041#endif
7042 )
a0714e2c 7043 const_sv = NULL;
beab0874 7044 else
601f1833 7045 const_sv = op_const_sv(block, NULL);
beab0874
JT		 7046
7047 if (cv) {
6867be6d 7048 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 7049
60ed1d8c
GS		 7050 /* if the subroutine doesn't exist and wasn't pre-declared
7051 * with a prototype, assume it will be AUTOLOADed,
7052 * skipping the prototype check
7053 */
7054 if (exists || SvPOK(cv))
dab1c735 7055 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
68dc0745 7056 /* already defined (or promised)? */
60ed1d8c 7057 if (exists || GvASSUMECV(gv)) {
eb8433b7
NC		 7058 if ((!block
7059#ifdef PERL_MAD
7060 || block->op_type == OP_NULL
7061#endif
fff96ff7 7062 )) {
d3cea301
SB		 7063 if (CvFLAGS(PL_compcv)) {
7064 /* might have had built-in attrs applied */
4dbb339a
FC		 7065 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7066 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7067 && ckWARN(WARN_MISC))
885ef6f5 7068 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
4dbb339a
FC		 7069 CvFLAGS(cv) |=
7070 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7071 & ~(CVf_LVALUE * pureperl));
d3cea301 7072 }
fff96ff7 7073 if (attrs) goto attrs;
aa689395 7074 /* just a "sub foo;" when &foo is already defined */
3280af22 7075 SAVEFREESV(PL_compcv);
aa689395 7076 goto done;
7077 }
eb8433b7
NC		 7078 if (block
7079#ifdef PERL_MAD
7080 && block->op_type != OP_NULL
7081#endif
7082 ) {
156d738f
FC		 7083 const line_t oldline = CopLINE(PL_curcop);
7084 if (PL_parser && PL_parser->copline != NOLINE)
53a7735b 7085 CopLINE_set(PL_curcop, PL_parser->copline);
156d738f
FC		 7086 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
7087 CopLINE_set(PL_curcop, oldline);
eb8433b7
NC		 7088#ifdef PERL_MAD
7089 if (!PL_minus_c) /* keep old one around for madskills */
7090#endif
7091 {
7092 /* (PL_madskills unset in used file.) */
7093 SvREFCNT_dec(cv);
7094 }
601f1833 7095 cv = NULL;
79072805 7096 }
79072805
LW		 7097 }
7098 }
beab0874 7099 if (const_sv) {
f84c484e 7100 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 7101 if (cv) {
0768512c 7102 assert(!CvROOT(cv) && !CvCONST(cv));
8be227ab 7103 cv_forget_slab(cv);
ad64d0ec 7104 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
beab0874
JT		 7105 CvXSUBANY(cv).any_ptr = const_sv;
7106 CvXSUB(cv) = const_sv_xsub;
7107 CvCONST_on(cv);
d04ba589 7108 CvISXSUB_on(cv);
beab0874
JT		 7109 }
7110 else {
c43ae56f 7111 GvCV_set(gv, NULL);
9c0a6090 7112 cv = newCONSTSUB_flags(
6e948d54 7113 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
9c0a6090
FC		 7114 const_sv
7115 );
7ad40bcb 7116 }
eb8433b7
NC		 7117 if (PL_madskills)
7118 goto install_block;
beab0874
JT		 7119 op_free(block);
7120 SvREFCNT_dec(PL_compcv);
7121 PL_compcv = NULL;
beab0874
JT		 7122 goto done;
7123 }
09330df8
Z		 7124 if (cv) { /* must reuse cv if autoloaded */
7125 /* transfer PL_compcv to cv */
7126 if (block
eb8433b7 7127#ifdef PERL_MAD
09330df8 7128 && block->op_type != OP_NULL
eb8433b7 7129#endif
09330df8 7130 ) {
eac910c8 7131 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
437388a9
NC		 7132 AV *const temp_av = CvPADLIST(cv);
7133 CV *const temp_cv = CvOUTSIDE(cv);
8be227ab
FC		 7134 const cv_flags_t slabbed = CvSLABBED(cv);
7135 OP * const cvstart = CvSTART(cv);
437388a9
NC		 7136
7137 assert(!CvWEAKOUTSIDE(cv));
7138 assert(!CvCVGV_RC(cv));
7139 assert(CvGV(cv) == gv);
7140
7141 SvPOK_off(cv);
eac910c8 7142 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
09330df8
Z		 7143 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7144 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
09330df8 7145 CvPADLIST(cv) = CvPADLIST(PL_compcv);
437388a9
NC		 7146 CvOUTSIDE(PL_compcv) = temp_cv;
7147 CvPADLIST(PL_compcv) = temp_av;
8be227ab
FC		 7148 CvSTART(cv) = CvSTART(PL_compcv);
7149 CvSTART(PL_compcv) = cvstart;
7150 if (slabbed) CvSLABBED_on(PL_compcv);
7151 else CvSLABBED_off(PL_compcv);
437388a9 7152
bad4ae38 7153 if (CvFILE(cv) && CvDYNFILE(cv)) {
437388a9
NC		 7154 Safefree(CvFILE(cv));
7155 }
437388a9
NC		 7156 CvFILE_set_from_cop(cv, PL_curcop);
7157 CvSTASH_set(cv, PL_curstash);
7158
09330df8
Z		 7159 /* inner references to PL_compcv must be fixed up ... */
7160 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7161 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7162 ++PL_sub_generation;
09bef843
SB		 7163 }
7164 else {
09330df8
Z		 7165 /* Might have had built-in attributes applied -- propagate them. */
7166 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
09bef843 7167 }
282f25c9 7168 /* ... before we throw it away */
3280af22 7169 SvREFCNT_dec(PL_compcv);
b5c19bd7 7170 PL_compcv = cv;
a0d0e21e
LW		 7171 }
7172 else {
3280af22 7173 cv = PL_compcv;
44a8e56a 7174 if (name) {
c43ae56f 7175 GvCV_set(gv, cv);
eb8433b7
NC		 7176 if (PL_madskills) {
7177 if (strEQ(name, "import")) {
ad64d0ec 7178 PL_formfeed = MUTABLE_SV(cv);
06f07c2f 7179 /* diag_listed_as: SKIPME */
fea10cf6 7180 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
eb8433b7
NC		 7181 }
7182 }
44a8e56a 7183 GvCVGEN(gv) = 0;
03d9f026
FC		 7184 if (HvENAME_HEK(GvSTASH(gv)))
7185 /* sub Foo::bar { (shift)+1 } */
7186 mro_method_changed_in(GvSTASH(gv));
44a8e56a 7187 }
a0d0e21e 7188 }
09330df8 7189 if (!CvGV(cv)) {
b3f91e91 7190 CvGV_set(cv, gv);
09330df8 7191 CvFILE_set_from_cop(cv, PL_curcop);
c68d9564 7192 CvSTASH_set(cv, PL_curstash);
09330df8 7193 }
8990e307 7194
e0260a5b 7195 if (ps) {
ad64d0ec 7196 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
e0260a5b
BF		 7197 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7198 }
4633a7c4 7199
eb8433b7 7200 install_block:
beab0874 7201 if (!block)
fb834abd 7202 goto attrs;
a0d0e21e 7203
aac018bb
NC		 7204 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7205 the debugger could be able to set a breakpoint in, so signal to
7206 pp_entereval that it should not throw away any saved lines at scope
7207 exit. */
7208
fd06b02c 7209 PL_breakable_sub_gen++;
69b22cd1
FC		 7210 /* This makes sub {}; work as expected. */
7211 if (block->op_type == OP_STUB) {
1496a290 7212 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 7213#ifdef PERL_MAD
7214 op_getmad(block,newblock,'B');
7215#else
09c2fd24 7216 op_free(block);
eb8433b7
NC		 7217#endif
7218 block = newblock;
7766f137 7219 }
69b22cd1
FC		 7220 else block->op_attached = 1;
7221 CvROOT(cv) = CvLVALUE(cv)
7222 ? newUNOP(OP_LEAVESUBLV, 0,
7223 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7224 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7766f137
GS		 7225 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7226 OpREFCNT_set(CvROOT(cv), 1);
8be227ab
FC		 7227#ifndef PL_OP_SLAB_ALLOC
7228 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7229 itself has a refcount. */
7230 CvSLABBED_off(cv);
7231 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7232#endif
7766f137
GS		 7233 CvSTART(cv) = LINKLIST(CvROOT(cv));
7234 CvROOT(cv)->op_next = 0;
a2efc822 7235 CALL_PEEP(CvSTART(cv));
d164302a 7236 finalize_optree(CvROOT(cv));
7766f137
GS		 7237
7238 /* now that optimizer has done its work, adjust pad values */
54310121 7239
dd2155a4
DM		 7240 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7241
7242 if (CvCLONE(cv)) {
beab0874
JT		 7243 assert(!CvCONST(cv));
7244 if (ps && !*ps && op_const_sv(block, cv))
7245 CvCONST_on(cv);
a0d0e21e 7246 }
79072805 7247
fb834abd
FC		 7248 attrs:
7249 if (attrs) {
7250 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7251 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7252 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
7253 }
7254
7255 if (block && has_name) {
3280af22 7256 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
c4420975 7257 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 7258 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7259 GV_ADDMULTI, SVt_PVHV);
44a8e56a 7260 HV *hv;
b081dd7e
NC		 7261 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7262 CopFILE(PL_curcop),
7263 (long)PL_subline,
7264 (long)CopLINE(PL_curcop));
bd61b366 7265 gv_efullname3(tmpstr, gv, NULL);
04fe65b0 7266 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
c60dbbc3 7267 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
44a8e56a 7268 hv = GvHVn(db_postponed);
c60dbbc3 7269 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
551405c4
AL		 7270 CV * const pcv = GvCV(db_postponed);
7271 if (pcv) {
7272 dSP;
7273 PUSHMARK(SP);
7274 XPUSHs(tmpstr);
7275 PUTBACK;
ad64d0ec 7276 call_sv(MUTABLE_SV(pcv), G_DISCARD);
551405c4 7277 }
44a8e56a 7278 }
7279 }
79072805 7280
13765c85 7281 if (name && ! (PL_parser && PL_parser->error_count))
0cd10f52 7282 process_special_blocks(name, gv, cv);
33fb7a6e 7283 }
ed094faf 7284
33fb7a6e 7285 done:
53a7735b
DM		 7286 if (PL_parser)
7287 PL_parser->copline = NOLINE;
33fb7a6e
NC		 7288 LEAVE_SCOPE(floor);
7289 return cv;
7290}
ed094faf 7291
33fb7a6e
NC		 7292STATIC void
7293S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
7294 CV *const cv)
7295{
7296 const char *const colon = strrchr(fullname,':');
7297 const char *const name = colon ? colon + 1 : fullname;
7298
7918f24d
NC		 7299 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7300
33fb7a6e 7301 if (*name == 'B') {
6952d67e 7302 if (strEQ(name, "BEGIN")) {
6867be6d 7303 const I32 oldscope = PL_scopestack_ix;
28757baa 7304 ENTER;
57843af0
GS		 7305 SAVECOPFILE(&PL_compiling);
7306 SAVECOPLINE(&PL_compiling);
16c63275 7307 SAVEVPTR(PL_curcop);
28757baa 7308
a58fb6f9 7309 DEBUG_x( dump_sub(gv) );
ad64d0ec 7310 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
c43ae56f 7311 GvCV_set(gv,0); /* cv has been hijacked */
3280af22 7312 call_list(oldscope, PL_beginav);
a6006777 7313
623e6609 7314 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 7315 LEAVE;
7316 }
33fb7a6e
NC		 7317 else
7318 return;
7319 } else {
7320 if (*name == 'E') {
7321 if strEQ(name, "END") {
a58fb6f9 7322 DEBUG_x( dump_sub(gv) );
ad64d0ec 7323 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
33fb7a6e
NC		 7324 } else
7325 return;
7326 } else if (*name == 'U') {
7327 if (strEQ(name, "UNITCHECK")) {
7328 /* It's never too late to run a unitcheck block */
ad64d0ec 7329 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
33fb7a6e
NC		 7330 }
7331 else
7332 return;
7333 } else if (*name == 'C') {
7334 if (strEQ(name, "CHECK")) {
a2a5de95 7335 if (PL_main_start)
dcbac5bb 7336 /* diag_listed_as: Too late to run %s block */
a2a5de95
NC		 7337 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7338 "Too late to run CHECK block");
ad64d0ec 7339 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
33fb7a6e
NC		 7340 }
7341 else
7342 return;
7343 } else if (*name == 'I') {
7344 if (strEQ(name, "INIT")) {
a2a5de95 7345 if (PL_main_start)
dcbac5bb 7346 /* diag_listed_as: Too late to run %s block */
a2a5de95
NC		 7347 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7348 "Too late to run INIT block");
ad64d0ec 7349 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
33fb7a6e
NC		 7350 }
7351 else
7352 return;
7353 } else
7354 return;
a58fb6f9 7355 DEBUG_x( dump_sub(gv) );
c43ae56f 7356 GvCV_set(gv,0); /* cv has been hijacked */
79072805 7357 }
79072805
LW		 7358}
7359
954c1994
GS		 7360/*
7361=for apidoc newCONSTSUB
7362
3453414d
BF		 7363See L</newCONSTSUB_flags>.
7364
7365=cut
7366*/
7367
7368CV *
7369Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7370{
9c0a6090 7371 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
3453414d
BF		 7372}
7373
7374/*
7375=for apidoc newCONSTSUB_flags
7376
954c1994
GS		 7377Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7378eligible for inlining at compile-time.
7379
3453414d
BF		 7380Currently, the only useful value for C<flags> is SVf_UTF8.
7381
99ab892b
NC		 7382Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7383which won't be called if used as a destructor, but will suppress the overhead
7384of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
7385compile time.)
7386
954c1994
GS		 7387=cut
7388*/
7389
beab0874 7390CV *
9c0a6090
FC		 7391Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7392 U32 flags, SV *sv)
5476c433 7393{
27da23d5 7394 dVAR;
beab0874 7395 CV* cv;
cbf82dd0 7396#ifdef USE_ITHREADS
54d012c6 7397 const char *const file = CopFILE(PL_curcop);
cbf82dd0
NC		 7398#else
7399 SV *const temp_sv = CopFILESV(PL_curcop);
def18e4c 7400 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
cbf82dd0 7401#endif
5476c433 7402
11faa288 7403 ENTER;
11faa288 7404
401667e9
DM		 7405 if (IN_PERL_RUNTIME) {
7406 /* at runtime, it's not safe to manipulate PL_curcop: it may be
7407 * an op shared between threads. Use a non-shared COP for our
7408 * dirty work */
7409 SAVEVPTR(PL_curcop);
08f1b312
FC		 7410 SAVECOMPILEWARNINGS();
7411 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
401667e9
DM		 7412 PL_curcop = &PL_compiling;
7413 }
f4dd75d9 7414 SAVECOPLINE(PL_curcop);
53a7735b 7415 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 7416
7417 SAVEHINTS();
3280af22 7418 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 7419
7420 if (stash) {
03d9f026 7421 SAVEGENERICSV(PL_curstash);
03d9f026 7422 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11faa288 7423 }
5476c433 7424
bad4ae38 7425 /* file becomes the CvFILE. For an XS, it's usually static storage,
cbf82dd0
NC		 7426 and so doesn't get free()d. (It's expected to be from the C pre-
7427 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee 7428 and we need it to get freed. */
8e1fa37c 7429 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
8f82b567 7430 &sv, XS_DYNAMIC_FILENAME | flags);
beab0874
JT		 7431 CvXSUBANY(cv).any_ptr = sv;
7432 CvCONST_on(cv);
5476c433 7433
11faa288 7434 LEAVE;
beab0874
JT		 7435
7436 return cv;
5476c433
JD		 7437}
7438
77004dee
NC		 7439CV *
7440Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7441 const char *const filename, const char *const proto,
7442 U32 flags)
7443{
032a0447
FC		 7444 PERL_ARGS_ASSERT_NEWXS_FLAGS;
7445 return newXS_len_flags(
8f82b567 7446 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
032a0447
FC		 7447 );
7448}
7449
7450CV *
7451Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7452 XSUBADDR_t subaddr, const char *const filename,
8f82b567
FC		 7453 const char *const proto, SV **const_svp,
7454 U32 flags)
032a0447 7455{
3453414d 7456 CV *cv;
77004dee 7457
032a0447 7458 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7918f24d 7459
3453414d 7460 {
032a0447
FC		 7461 GV * const gv = name
7462 ? gv_fetchpvn(
7463 name,len,GV_ADDMULTI|flags,SVt_PVCV
7464 )
7465 : gv_fetchpv(
3453414d
BF		 7466 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
7467 GV_ADDMULTI | flags, SVt_PVCV);
7468
7469 if (!subaddr)
7470 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7471
7472 if ((cv = (name ? GvCV(gv) : NULL))) {
7473 if (GvCVGEN(gv)) {
7474 /* just a cached method */
7475 SvREFCNT_dec(cv);
7476 cv = NULL;
7477 }
7478 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7479 /* already defined (or promised) */
18225a01 7480 /* Redundant check that allows us to avoid creating an SV
156d738f
FC		 7481 most of the time: */
7482 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
799fd3b9 7483 const line_t oldline = CopLINE(PL_curcop);
799fd3b9
FC		 7484 if (PL_parser && PL_parser->copline != NOLINE)
7485 CopLINE_set(PL_curcop, PL_parser->copline);
156d738f 7486 report_redefined_cv(newSVpvn_flags(
46538741 7487 name,len,(flags&SVf_UTF8)|SVs_TEMP
156d738f
FC		 7488 ),
7489 cv, const_svp);
799fd3b9 7490 CopLINE_set(PL_curcop, oldline);
3453414d
BF		 7491 }
7492 SvREFCNT_dec(cv);
7493 cv = NULL;
7494 }
7495 }
7496
7497 if (cv) /* must reuse cv if autoloaded */
7498 cv_undef(cv);
7499 else {
7500 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7501 if (name) {
7502 GvCV_set(gv,cv);
7503 GvCVGEN(gv) = 0;
03d9f026
FC		 7504 if (HvENAME_HEK(GvSTASH(gv)))
7505 mro_method_changed_in(GvSTASH(gv)); /* newXS */
3453414d
BF		 7506 }
7507 }
7508 if (!name)
7509 CvANON_on(cv);
7510 CvGV_set(cv, gv);
7511 (void)gv_fetchfile(filename);
7512 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7513 an external constant string */
7514 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7515 CvISXSUB_on(cv);
7516 CvXSUB(cv) = subaddr;
7517
7518 if (name)
7519 process_special_blocks(name, gv, cv);
7520 }
7521
77004dee 7522 if (flags & XS_DYNAMIC_FILENAME) {
bad4ae38
FC		 7523 CvFILE(cv) = savepv(filename);
7524 CvDYNFILE_on(cv);
77004dee 7525 }
bad4ae38 7526 sv_setpv(MUTABLE_SV(cv), proto);
77004dee
NC		 7527 return cv;
7528}
7529
186a5ba8
FC		 7530CV *
7531Perl_newSTUB(pTHX_ GV *gv, bool fake)
7532{
7533 register CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7534 PERL_ARGS_ASSERT_NEWSTUB;
7535 assert(!GvCVu(gv));
7536 GvCV_set(gv, cv);
7537 GvCVGEN(gv) = 0;
7538 if (!fake && HvENAME_HEK(GvSTASH(gv)))
7539 mro_method_changed_in(GvSTASH(gv));
7540 CvGV_set(cv, gv);
7541 CvFILE_set_from_cop(cv, PL_curcop);
7542 CvSTASH_set(cv, PL_curstash);
7543 GvMULTI_on(gv);
7544 return cv;
7545}
7546
954c1994
GS		 7547/*
7548=for apidoc U||newXS
7549
77004dee
NC		 7550Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7551static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 7552
7553=cut
7554*/
7555
57d3b86d 7556CV *
bfed75c6 7557Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 7558{
7918f24d 7559 PERL_ARGS_ASSERT_NEWXS;
ce9f52ad
FC		 7560 return newXS_len_flags(
7561 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7562 );
79072805
LW		 7563}
7564
eb8433b7
NC		 7565#ifdef PERL_MAD
7566OP *
7567#else
79072805 7568void
eb8433b7 7569#endif
864dbfa3 7570Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 7571{
97aff369 7572 dVAR;
79072805 7573 register CV *cv;
eb8433b7
NC		 7574#ifdef PERL_MAD
7575 OP* pegop = newOP(OP_NULL, 0);
7576#endif
79072805 7577
0bd48802 7578 GV * const gv = o
f776e3cd 7579 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 7580 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 7581
a5f75d66 7582 GvMULTI_on(gv);
155aba94 7583 if ((cv = GvFORM(gv))) {
599cee73 7584 if (ckWARN(WARN_REDEFINE)) {
6867be6d 7585 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 7586 if (PL_parser && PL_parser->copline != NOLINE)
7587 CopLINE_set(PL_curcop, PL_parser->copline);
ee6d2783
NC		 7588 if (o) {
7589 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7590 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7591 } else {
dcbac5bb 7592 /* diag_listed_as: Format %s redefined */
ee6d2783
NC		 7593 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7594 "Format STDOUT redefined");
7595 }
57843af0 7596 CopLINE_set(PL_curcop, oldline);
79072805 7597 }
8990e307 7598 SvREFCNT_dec(cv);
79072805 7599 }
3280af22 7600 cv = PL_compcv;
79072805 7601 GvFORM(gv) = cv;
b3f91e91 7602 CvGV_set(cv, gv);
a636914a 7603 CvFILE_set_from_cop(cv, PL_curcop);
79072805 7604
a0d0e21e 7605
dd2155a4 7606 pad_tidy(padtidy_FORMAT);
79072805 7607 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 7608 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7609 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 7610 CvSTART(cv) = LINKLIST(CvROOT(cv));
7611 CvROOT(cv)->op_next = 0;
a2efc822 7612 CALL_PEEP(CvSTART(cv));
aee4f072 7613 finalize_optree(CvROOT(cv));
8be227ab 7614 cv_forget_slab(cv);
eb8433b7
NC		 7615#ifdef PERL_MAD
7616 op_getmad(o,pegop,'n');
7617 op_getmad_weak(block, pegop, 'b');
7618#else
11343788 7619 op_free(o);
eb8433b7 7620#endif
53a7735b
DM		 7621 if (PL_parser)
7622 PL_parser->copline = NOLINE;
8990e307 7623 LEAVE_SCOPE(floor);
eb8433b7
NC		 7624#ifdef PERL_MAD
7625 return pegop;
7626#endif
79072805
LW		 7627}
7628
7629OP *
864dbfa3 7630Perl_newANONLIST(pTHX_ OP *o)
79072805 7631{
78c72037 7632 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 7633}
7634
7635OP *
864dbfa3 7636Perl_newANONHASH(pTHX_ OP *o)
79072805 7637{
78c72037 7638 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 7639}
7640
7641OP *
864dbfa3 7642Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 7643{
5f66b61c 7644 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 7645}
7646
7647OP *
7648Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7649{
a0d0e21e 7650 return newUNOP(OP_REFGEN, 0,
09bef843 7651 newSVOP(OP_ANONCODE, 0,
ad64d0ec 7652 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
79072805
LW		 7653}
7654
7655OP *
864dbfa3 7656Perl_oopsAV(pTHX_ OP *o)
79072805 7657{
27da23d5 7658 dVAR;
7918f24d
NC		 7659
7660 PERL_ARGS_ASSERT_OOPSAV;
7661
ed6116ce
LW		 7662 switch (o->op_type) {
7663 case OP_PADSV:
7664 o->op_type = OP_PADAV;
22c35a8c 7665 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 7666 return ref(o, OP_RV2AV);
b2ffa427 7667
ed6116ce 7668 case OP_RV2SV:
79072805 7669 o->op_type = OP_RV2AV;
22c35a8c 7670 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 7671 ref(o, OP_RV2AV);
ed6116ce
LW		 7672 break;
7673
7674 default:
9b387841 7675 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 7676 break;
7677 }
79072805
LW		 7678 return o;
7679}
7680
7681OP *
864dbfa3 7682Perl_oopsHV(pTHX_ OP *o)
79072805 7683{
27da23d5 7684 dVAR;
7918f24d
NC		 7685
7686 PERL_ARGS_ASSERT_OOPSHV;
7687
ed6116ce
LW		 7688 switch (o->op_type) {
7689 case OP_PADSV:
7690 case OP_PADAV:
7691 o->op_type = OP_PADHV;
22c35a8c 7692 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 7693 return ref(o, OP_RV2HV);
ed6116ce
LW		 7694
7695 case OP_RV2SV:
7696 case OP_RV2AV:
79072805 7697 o->op_type = OP_RV2HV;
22c35a8c 7698 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 7699 ref(o, OP_RV2HV);
ed6116ce
LW		 7700 break;
7701
7702 default:
9b387841 7703 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 7704 break;
7705 }
79072805
LW		 7706 return o;
7707}
7708
7709OP *
864dbfa3 7710Perl_newAVREF(pTHX_ OP *o)
79072805 7711{
27da23d5 7712 dVAR;
7918f24d
NC		 7713
7714 PERL_ARGS_ASSERT_NEWAVREF;
7715
ed6116ce
LW		 7716 if (o->op_type == OP_PADANY) {
7717 o->op_type = OP_PADAV;
22c35a8c 7718 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 7719 return o;
ed6116ce 7720 }
a2a5de95 7721 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
d1d15184 7722 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7723 "Using an array as a reference is deprecated");
a1063b2d 7724 }
79072805
LW		 7725 return newUNOP(OP_RV2AV, 0, scalar(o));
7726}
7727
7728OP *
864dbfa3 7729Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 7730{
82092f1d 7731 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 7732 return newUNOP(OP_NULL, 0, o);
748a9306 7733 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 7734}
7735
7736OP *
864dbfa3 7737Perl_newHVREF(pTHX_ OP *o)
79072805 7738{
27da23d5 7739 dVAR;
7918f24d
NC		 7740
7741 PERL_ARGS_ASSERT_NEWHVREF;
7742
ed6116ce
LW		 7743 if (o->op_type == OP_PADANY) {
7744 o->op_type = OP_PADHV;
22c35a8c 7745 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 7746 return o;
ed6116ce 7747 }
a2a5de95 7748 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
d1d15184 7749 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7750 "Using a hash as a reference is deprecated");
a1063b2d 7751 }
79072805
LW		 7752 return newUNOP(OP_RV2HV, 0, scalar(o));
7753}
7754
7755OP *
864dbfa3 7756Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 7757{
c07a80fd 7758 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 7759}
7760
7761OP *
864dbfa3 7762Perl_newSVREF(pTHX_ OP *o)
79072805 7763{
27da23d5 7764 dVAR;
7918f24d
NC		 7765
7766 PERL_ARGS_ASSERT_NEWSVREF;
7767
ed6116ce
LW		 7768 if (o->op_type == OP_PADANY) {
7769 o->op_type = OP_PADSV;
22c35a8c 7770 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 7771 return o;
ed6116ce 7772 }
79072805
LW		 7773 return newUNOP(OP_RV2SV, 0, scalar(o));
7774}
7775
61b743bb
DM		 7776/* Check routines. See the comments at the top of this file for details
7777 * on when these are called */
79072805
LW		 7778
7779OP *
cea2e8a9 7780Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 7781{
7918f24d
NC		 7782 PERL_ARGS_ASSERT_CK_ANONCODE;
7783
cc76b5cc 7784 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
eb8433b7 7785 if (!PL_madskills)
1d866c12 7786 cSVOPo->op_sv = NULL;
5dc0d613 7787 return o;
5f05dabc 7788}
7789
7790OP *
cea2e8a9 7791Perl_ck_bitop(pTHX_ OP *o)
55497cff 7792{
97aff369 7793 dVAR;
7918f24d
NC		 7794
7795 PERL_ARGS_ASSERT_CK_BITOP;
7796
d5ec2987 7797 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 7798 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7799 && (o->op_type == OP_BIT_OR
7800 || o->op_type == OP_BIT_AND
7801 || o->op_type == OP_BIT_XOR))
276b2a0c 7802 {
1df70142
AL		 7803 const OP * const left = cBINOPo->op_first;
7804 const OP * const right = left->op_sibling;
96a925ab
YST		 7805 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7806 (left->op_flags & OPf_PARENS) == 0) ||
7807 (OP_IS_NUMCOMPARE(right->op_type) &&
7808 (right->op_flags & OPf_PARENS) == 0))
a2a5de95
NC		 7809 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7810 "Possible precedence problem on bitwise %c operator",
7811 o->op_type == OP_BIT_OR ? '|'
7812 : o->op_type == OP_BIT_AND ? '&' : '^'
7813 );
276b2a0c 7814 }
5dc0d613 7815 return o;
55497cff 7816}
7817
89474f50
FC		 7818PERL_STATIC_INLINE bool
7819is_dollar_bracket(pTHX_ const OP * const o)
7820{
7821 const OP *kid;
7822 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
7823 && (kid = cUNOPx(o)->op_first)
7824 && kid->op_type == OP_GV
7825 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
7826}
7827
7828OP *
7829Perl_ck_cmp(pTHX_ OP *o)
7830{
7831 PERL_ARGS_ASSERT_CK_CMP;
7832 if (ckWARN(WARN_SYNTAX)) {
7833 const OP *kid = cUNOPo->op_first;
7834 if (kid && (
7c2b3c78
FC		 7835 (
7836 is_dollar_bracket(aTHX_ kid)
7837 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
7838 )
7839 || ( kid->op_type == OP_CONST
7840 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
89474f50
FC		 7841 ))
7842 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7843 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
7844 }
7845 return o;
7846}
7847
55497cff 7848OP *
cea2e8a9 7849Perl_ck_concat(pTHX_ OP *o)
79072805 7850{
0bd48802 7851 const OP * const kid = cUNOPo->op_first;
7918f24d
NC		 7852
7853 PERL_ARGS_ASSERT_CK_CONCAT;
96a5add6 7854 PERL_UNUSED_CONTEXT;
7918f24d 7855
df91b2c5
AE		 7856 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7857 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 7858 o->op_flags |= OPf_STACKED;
11343788 7859 return o;
79072805
LW		 7860}
7861
7862OP *
cea2e8a9 7863Perl_ck_spair(pTHX_ OP *o)
79072805 7864{
27da23d5 7865 dVAR;
7918f24d
NC		 7866
7867 PERL_ARGS_ASSERT_CK_SPAIR;
7868
11343788 7869 if (o->op_flags & OPf_KIDS) {
79072805 7870 OP* newop;
a0d0e21e 7871 OP* kid;
6867be6d 7872 const OPCODE type = o->op_type;
5dc0d613 7873 o = modkids(ck_fun(o), type);
11343788 7874 kid = cUNOPo->op_first;
a0d0e21e 7875 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 7876 if (newop) {
7877 const OPCODE type = newop->op_type;
7878 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7879 type == OP_PADAV || type == OP_PADHV ||
7880 type == OP_RV2AV || type == OP_RV2HV)
7881 return o;
a0d0e21e 7882 }
eb8433b7
NC		 7883#ifdef PERL_MAD
7884 op_getmad(kUNOP->op_first,newop,'K');
7885#else
a0d0e21e 7886 op_free(kUNOP->op_first);
eb8433b7 7887#endif
a0d0e21e
LW		 7888 kUNOP->op_first = newop;
7889 }
22c35a8c 7890 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 7891 return ck_fun(o);
a0d0e21e
LW		 7892}
7893
7894OP *
cea2e8a9 7895Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 7896{
7918f24d
NC		 7897 PERL_ARGS_ASSERT_CK_DELETE;
7898
11343788 7899 o = ck_fun(o);
5dc0d613 7900 o->op_private = 0;
11343788 7901 if (o->op_flags & OPf_KIDS) {
551405c4 7902 OP * const kid = cUNOPo->op_first;
01020589
GS		 7903 switch (kid->op_type) {
7904 case OP_ASLICE:
7905 o->op_flags |= OPf_SPECIAL;
7906 /* FALL THROUGH */
7907 case OP_HSLICE:
5dc0d613 7908 o->op_private |= OPpSLICE;
01020589
GS		 7909 break;
7910 case OP_AELEM:
7911 o->op_flags |= OPf_SPECIAL;
7912 /* FALL THROUGH */
7913 case OP_HELEM:
7914 break;
7915 default:
7916 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 7917 OP_DESC(o));
01020589 7918 }
7332a6c4
VP		 7919 if (kid->op_private & OPpLVAL_INTRO)
7920 o->op_private |= OPpLVAL_INTRO;
93c66552 7921 op_null(kid);
79072805 7922 }
11343788 7923 return o;
79072805
LW		 7924}
7925
7926OP *
96e176bf
CL		 7927Perl_ck_die(pTHX_ OP *o)
7928{
7918f24d
NC		 7929 PERL_ARGS_ASSERT_CK_DIE;
7930
96e176bf
CL		 7931#ifdef VMS
7932 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7933#endif
7934 return ck_fun(o);
7935}
7936
7937OP *
cea2e8a9 7938Perl_ck_eof(pTHX_ OP *o)
79072805 7939{
97aff369 7940 dVAR;
79072805 7941
7918f24d
NC		 7942 PERL_ARGS_ASSERT_CK_EOF;
7943
11343788 7944 if (o->op_flags & OPf_KIDS) {
3500db16 7945 OP *kid;
11343788 7946 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 7947 OP * const newop
7948 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 7949#ifdef PERL_MAD
7950 op_getmad(o,newop,'O');
7951#else
11343788 7952 op_free(o);
eb8433b7
NC		 7953#endif
7954 o = newop;
8990e307 7955 }
3500db16
FC		 7956 o = ck_fun(o);
7957 kid = cLISTOPo->op_first;
7958 if (kid->op_type == OP_RV2GV)
7959 kid->op_private |= OPpALLOW_FAKE;
79072805 7960 }
11343788 7961 return o;
79072805
LW		 7962}
7963
7964OP *
cea2e8a9 7965Perl_ck_eval(pTHX_ OP *o)
79072805 7966{
27da23d5 7967 dVAR;
7918f24d
NC		 7968
7969 PERL_ARGS_ASSERT_CK_EVAL;
7970
3280af22 7971 PL_hints |= HINT_BLOCK_SCOPE;
11343788 7972 if (o->op_flags & OPf_KIDS) {
46c461b5 7973 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 7974
93a17b20 7975 if (!kid) {
11343788 7976 o->op_flags &= ~OPf_KIDS;
93c66552 7977 op_null(o);
79072805 7978 }
b14574b4 7979 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 7980 LOGOP *enter;
eb8433b7 7981#ifdef PERL_MAD
1d866c12 7982 OP* const oldo = o;
eb8433b7 7983#endif
79072805 7984
11343788 7985 cUNOPo->op_first = 0;
eb8433b7 7986#ifndef PERL_MAD
11343788 7987 op_free(o);
eb8433b7 7988#endif
79072805 7989
b7dc083c 7990 NewOp(1101, enter, 1, LOGOP);
79072805 7991 enter->op_type = OP_ENTERTRY;
22c35a8c 7992 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 7993 enter->op_private = 0;
7994
7995 /* establish postfix order */
7996 enter->op_next = (OP*)enter;
7997
2fcb4757 7998 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11343788 7999 o->op_type = OP_LEAVETRY;
22c35a8c 8000 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 8001 enter->op_other = o;
eb8433b7 8002 op_getmad(oldo,o,'O');
11343788 8003 return o;
79072805 8004 }
b5c19bd7 8005 else {
473986ff 8006 scalar((OP*)kid);
b5c19bd7
DM		 8007 PL_cv_has_eval = 1;
8008 }
79072805
LW		 8009 }
8010 else {
a4a3cf74 8011 const U8 priv = o->op_private;
eb8433b7 8012#ifdef PERL_MAD
1d866c12 8013 OP* const oldo = o;
eb8433b7 8014#else
11343788 8015 op_free(o);
eb8433b7 8016#endif
7d789282 8017 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
eb8433b7 8018 op_getmad(oldo,o,'O');
79072805 8019 }
3280af22 8020 o->op_targ = (PADOFFSET)PL_hints;
547ae129 8021 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7d789282
FC		 8022 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8023 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
996c9baa
VP		 8024 /* Store a copy of %^H that pp_entereval can pick up. */
8025 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
defdfed5 8026 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
0d863452
RH		 8027 cUNOPo->op_first->op_sibling = hhop;
8028 o->op_private |= OPpEVAL_HAS_HH;
915a83fe
FC		 8029 }
8030 if (!(o->op_private & OPpEVAL_BYTES)
2846acbf 8031 && FEATURE_UNIEVAL_IS_ENABLED)
802a15e9 8032 o->op_private |= OPpEVAL_UNICODE;
11343788 8033 return o;
79072805
LW		 8034}
8035
8036OP *
d98f61e7
GS		 8037Perl_ck_exit(pTHX_ OP *o)
8038{
7918f24d
NC		 8039 PERL_ARGS_ASSERT_CK_EXIT;
8040
d98f61e7 8041#ifdef VMS
551405c4 8042 HV * const table = GvHV(PL_hintgv);
d98f61e7 8043 if (table) {
a4fc7abc 8044 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 8045 if (svp && *svp && SvTRUE(*svp))
8046 o->op_private |= OPpEXIT_VMSISH;
8047 }
96e176bf 8048 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 8049#endif
8050 return ck_fun(o);
8051}
8052
8053OP *
cea2e8a9 8054Perl_ck_exec(pTHX_ OP *o)
79072805 8055{
7918f24d
NC		 8056 PERL_ARGS_ASSERT_CK_EXEC;
8057
11343788 8058 if (o->op_flags & OPf_STACKED) {
6867be6d 8059 OP *kid;
11343788
MB		 8060 o = ck_fun(o);
8061 kid = cUNOPo->op_first->op_sibling;
8990e307 8062 if (kid->op_type == OP_RV2GV)
93c66552 8063 op_null(kid);
79072805 8064 }
463ee0b2 8065 else
11343788
MB		 8066 o = listkids(o);
8067 return o;
79072805
LW		 8068}
8069
8070OP *
cea2e8a9 8071Perl_ck_exists(pTHX_ OP *o)
5f05dabc 8072{
97aff369 8073 dVAR;
7918f24d
NC		 8074
8075 PERL_ARGS_ASSERT_CK_EXISTS;
8076
5196be3e
MB		 8077 o = ck_fun(o);
8078 if (o->op_flags & OPf_KIDS) {
46c461b5 8079 OP * const kid = cUNOPo->op_first;
afebc493
GS		 8080 if (kid->op_type == OP_ENTERSUB) {
8081 (void) ref(kid, o->op_type);
13765c85
DM		 8082 if (kid->op_type != OP_RV2CV
8083 && !(PL_parser && PL_parser->error_count))
afebc493 8084 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 8085 OP_DESC(o));
afebc493
GS		 8086 o->op_private |= OPpEXISTS_SUB;
8087 }
8088 else if (kid->op_type == OP_AELEM)
01020589
GS		 8089 o->op_flags |= OPf_SPECIAL;
8090 else if (kid->op_type != OP_HELEM)
b0fdf69e 8091 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
53e06cf0 8092 OP_DESC(o));
93c66552 8093 op_null(kid);
5f05dabc 8094 }
5196be3e 8095 return o;
5f05dabc 8096}
8097
79072805 8098OP *
cea2e8a9 8099Perl_ck_rvconst(pTHX_ register OP *o)
79072805 8100{
27da23d5 8101 dVAR;
0bd48802 8102 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 8103
7918f24d
NC		 8104 PERL_ARGS_ASSERT_CK_RVCONST;
8105
3280af22 8106 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 8107 if (o->op_type == OP_RV2CV)
8108 o->op_private &= ~1;
8109
79072805 8110 if (kid->op_type == OP_CONST) {
44a8e56a 8111 int iscv;
8112 GV *gv;
504618e9 8113 SV * const kidsv = kid->op_sv;
44a8e56a 8114
779c5bc9
GS		 8115 /* Is it a constant from cv_const_sv()? */
8116 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 8117 SV * const rsv = SvRV(kidsv);
42d0e0b7 8118 const svtype type = SvTYPE(rsv);
bd61b366 8119 const char *badtype = NULL;
779c5bc9
GS		 8120
8121 switch (o->op_type) {
8122 case OP_RV2SV:
42d0e0b7 8123 if (type > SVt_PVMG)
779c5bc9
GS		 8124 badtype = "a SCALAR";
8125 break;
8126 case OP_RV2AV:
42d0e0b7 8127 if (type != SVt_PVAV)
779c5bc9
GS		 8128 badtype = "an ARRAY";
8129 break;
8130 case OP_RV2HV:
42d0e0b7 8131 if (type != SVt_PVHV)
779c5bc9 8132 badtype = "a HASH";
779c5bc9
GS		 8133 break;
8134 case OP_RV2CV:
42d0e0b7 8135 if (type != SVt_PVCV)
779c5bc9
GS		 8136 badtype = "a CODE";
8137 break;
8138 }
8139 if (badtype)
cea2e8a9 8140 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 8141 return o;
8142 }
ce10b5d1 8143 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 8144 const char *badthing;
5dc0d613 8145 switch (o->op_type) {
44a8e56a 8146 case OP_RV2SV:
8147 badthing = "a SCALAR";
8148 break;
8149 case OP_RV2AV:
8150 badthing = "an ARRAY";
8151 break;
8152 case OP_RV2HV:
8153 badthing = "a HASH";
8154 break;
5f66b61c
AL		 8155 default:
8156 badthing = NULL;
8157 break;
44a8e56a 8158 }
8159 if (badthing)
1c846c1f 8160 Perl_croak(aTHX_
95b63a38 8161 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 8162 SVfARG(kidsv), badthing);
44a8e56a 8163 }
93233ece
CS		 8164 /*
8165 * This is a little tricky. We only want to add the symbol if we
8166 * didn't add it in the lexer. Otherwise we get duplicate strict
8167 * warnings. But if we didn't add it in the lexer, we must at
8168 * least pretend like we wanted to add it even if it existed before,
8169 * or we get possible typo warnings. OPpCONST_ENTERED says
8170 * whether the lexer already added THIS instance of this symbol.
8171 */
5196be3e 8172 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 8173 do {
7a5fd60d 8174 gv = gv_fetchsv(kidsv,
748a9306 8175 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 8176 iscv
8177 ? SVt_PVCV
11343788 8178 : o->op_type == OP_RV2SV
a0d0e21e 8179 ? SVt_PV
11343788 8180 : o->op_type == OP_RV2AV
a0d0e21e 8181 ? SVt_PVAV
11343788 8182 : o->op_type == OP_RV2HV
a0d0e21e
LW		 8183 ? SVt_PVHV
8184 : SVt_PVGV);
93233ece
CS		 8185 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8186 if (gv) {
8187 kid->op_type = OP_GV;
8188 SvREFCNT_dec(kid->op_sv);
350de78d 8189#ifdef USE_ITHREADS
638eceb6 8190 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 8191 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 8192 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 8193 GvIN_PAD_on(gv);
ad64d0ec 8194 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
350de78d 8195#else
b37c2d43 8196 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 8197#endif
23f1ca44 8198 kid->op_private = 0;
76cd736e 8199 kid->op_ppaddr = PL_ppaddr[OP_GV];
2acc3314
FC		 8200 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8201 SvFAKE_off(gv);
a0d0e21e 8202 }
79072805 8203 }
11343788 8204 return o;
79072805
LW		 8205}
8206
8207OP *
cea2e8a9 8208Perl_ck_ftst(pTHX_ OP *o)
79072805 8209{
27da23d5 8210 dVAR;
6867be6d 8211 const I32 type = o->op_type;
79072805 8212
7918f24d
NC		 8213 PERL_ARGS_ASSERT_CK_FTST;
8214
d0dca557 8215 if (o->op_flags & OPf_REF) {
6f207bd3 8216 NOOP;
d0dca557
JD		 8217 }
8218 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 8219 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 8220 const OPCODE kidtype = kid->op_type;
79072805 8221
1496a290 8222 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 8223 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 8224 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 8225#ifdef PERL_MAD
8226 op_getmad(o,newop,'O');
8227#else
11343788 8228 op_free(o);
eb8433b7 8229#endif
1d866c12 8230 return newop;
79072805 8231 }
6ecf81d6 8232 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
1af34c76 8233 o->op_private |= OPpFT_ACCESS;
ef69c8fc 8234 if (PL_check[kidtype] == Perl_ck_ftst
bbd91306 8235 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
fbb0b3b3 8236 o->op_private |= OPpFT_STACKED;
bbd91306 8237 kid->op_private |= OPpFT_STACKING;
8db8f6b6
FC		 8238 if (kidtype == OP_FTTTY && (
8239 !(kid->op_private & OPpFT_STACKED)
8240 || kid->op_private & OPpFT_AFTER_t
8241 ))
8242 o->op_private |= OPpFT_AFTER_t;
bbd91306 8243 }
79072805
LW		 8244 }
8245 else {
eb8433b7 8246#ifdef PERL_MAD
1d866c12 8247 OP* const oldo = o;
eb8433b7 8248#else
11343788 8249 op_free(o);
eb8433b7 8250#endif
79072805 8251 if (type == OP_FTTTY)
8fde6460 8252 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 8253 else
d0dca557 8254 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 8255 op_getmad(oldo,o,'O');
79072805 8256 }
11343788 8257 return o;
79072805
LW		 8258}
8259
8260OP *
cea2e8a9 8261Perl_ck_fun(pTHX_ OP *o)
79072805 8262{
97aff369 8263 dVAR;
6867be6d 8264 const int type = o->op_type;
22c35a8c 8265 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 8266
7918f24d
NC		 8267 PERL_ARGS_ASSERT_CK_FUN;
8268
11343788 8269 if (o->op_flags & OPf_STACKED) {
79072805
LW		 8270 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8271 oa &= ~OA_OPTIONAL;
8272 else
11343788 8273 return no_fh_allowed(o);
79072805
LW		 8274 }
8275
11343788 8276 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 8277 OP **tokid = &cLISTOPo->op_first;
8278 register OP *kid = cLISTOPo->op_first;
8279 OP *sibl;
8280 I32 numargs = 0;
ea5703f4 8281 bool seen_optional = FALSE;
6867be6d 8282
8990e307 8283 if (kid->op_type == OP_PUSHMARK ||
155aba94 8284 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 8285 {
79072805
LW		 8286 tokid = &kid->op_sibling;
8287 kid = kid->op_sibling;
8288 }
f6a16869
FC		 8289 if (kid && kid->op_type == OP_COREARGS) {
8290 bool optional = FALSE;
8291 while (oa) {
8292 numargs++;
8293 if (oa & OA_OPTIONAL) optional = TRUE;
8294 oa = oa >> 4;
8295 }
8296 if (optional) o->op_private |= numargs;
8297 return o;
8298 }
79072805 8299
ea5703f4 8300 while (oa) {
72ec8a82 8301 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
ea5703f4
FC		 8302 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8303 *tokid = kid = newDEFSVOP();
8304 seen_optional = TRUE;
8305 }
8306 if (!kid) break;
8307
79072805
LW		 8308 numargs++;
8309 sibl = kid->op_sibling;
eb8433b7
NC		 8310#ifdef PERL_MAD
8311 if (!sibl && kid->op_type == OP_STUB) {
8312 numargs--;
8313 break;
8314 }
8315#endif
79072805
LW		 8316 switch (oa & 7) {
8317 case OA_SCALAR:
62c18ce2
GS		 8318 /* list seen where single (scalar) arg expected? */
8319 if (numargs == 1 && !(oa >> 4)
8320 && kid->op_type == OP_LIST && type != OP_SCALAR)
8321 {
ce16c625 8322 return too_many_arguments_pv(o,PL_op_desc[type], 0);
62c18ce2 8323 }
79072805
LW		 8324 scalar(kid);
8325 break;
8326 case OA_LIST:
8327 if (oa < 16) {
8328 kid = 0;
8329 continue;
8330 }
8331 else
8332 list(kid);
8333 break;
8334 case OA_AVREF:
936edb8b 8335 if ((type == OP_PUSH || type == OP_UNSHIFT)
a2a5de95
NC		 8336 && !kid->op_sibling)
8337 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8338 "Useless use of %s with no values",
8339 PL_op_desc[type]);
b2ffa427 8340
79072805 8341 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 8342 (kid->op_private & OPpCONST_BARE))
8343 {
551405c4 8344 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 8345 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
d1d15184 8346 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 8347 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8348 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 8349#ifdef PERL_MAD
8350 op_getmad(kid,newop,'K');
8351#else
79072805 8352 op_free(kid);
eb8433b7 8353#endif
79072805
LW		 8354 kid = newop;
8355 kid->op_sibling = sibl;
8356 *tokid = kid;
8357 }
d4fc4415
FC		 8358 else if (kid->op_type == OP_CONST
8359 && ( !SvROK(cSVOPx_sv(kid))
8360 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
8361 )
ce16c625 8362 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
d4fc4415
FC		 8363 /* Defer checks to run-time if we have a scalar arg */
8364 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8365 op_lvalue(kid, type);
8366 else scalar(kid);
79072805
LW		 8367 break;
8368 case OA_HVREF:
8369 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 8370 (kid->op_private & OPpCONST_BARE))
8371 {
551405c4 8372 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 8373 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
d1d15184 8374 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 8375 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
8376 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 8377#ifdef PERL_MAD
8378 op_getmad(kid,newop,'K');
8379#else
79072805 8380 op_free(kid);
eb8433b7 8381#endif
79072805
LW		 8382 kid = newop;
8383 kid->op_sibling = sibl;
8384 *tokid = kid;
8385 }
8990e307 8386 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
ce16c625 8387 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
3ad73efd 8388 op_lvalue(kid, type);
79072805
LW		 8389 break;
8390 case OA_CVREF:
8391 {
551405c4 8392 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805 8393 kid->op_sibling = 0;
5983a79d 8394 LINKLIST(kid);
79072805
LW		 8395 newop->op_next = newop;
8396 kid = newop;
8397 kid->op_sibling = sibl;
8398 *tokid = kid;
8399 }
8400 break;
8401 case OA_FILEREF:
c340be78 8402 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 8403 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 8404 (kid->op_private & OPpCONST_BARE))
8405 {
0bd48802 8406 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 8407 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 8408 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 8409 kid == cLISTOPo->op_last)
364daeac 8410 cLISTOPo->op_last = newop;
eb8433b7
NC		 8411#ifdef PERL_MAD
8412 op_getmad(kid,newop,'K');
8413#else
79072805 8414 op_free(kid);
eb8433b7 8415#endif
79072805
LW		 8416 kid = newop;
8417 }
1ea32a52
GS		 8418 else if (kid->op_type == OP_READLINE) {
8419 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
ce16c625 8420 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
1ea32a52 8421 }
79072805 8422 else {
35cd451c 8423 I32 flags = OPf_SPECIAL;
a6c40364 8424 I32 priv = 0;
2c8ac474
GS		 8425 PADOFFSET targ = 0;
8426
35cd451c 8427 /* is this op a FH constructor? */
853846ea 8428 if (is_handle_constructor(o,numargs)) {
bd61b366 8429 const char *name = NULL;
dd2155a4 8430 STRLEN len = 0;
2dc9cdca 8431 U32 name_utf8 = 0;
885f468a 8432 bool want_dollar = TRUE;
2c8ac474
GS		 8433
8434 flags = 0;
8435 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 8436 * need to "prove" flag does not mean something
8437 * else already - NI-S 1999/05/07
2c8ac474
GS		 8438 */
8439 priv = OPpDEREF;
8440 if (kid->op_type == OP_PADSV) {
f8503592
NC		 8441 SV *const namesv
8442 = PAD_COMPNAME_SV(kid->op_targ);
8443 name = SvPV_const(namesv, len);
2dc9cdca 8444 name_utf8 = SvUTF8(namesv);
2c8ac474
GS		 8445 }
8446 else if (kid->op_type == OP_RV2SV
8447 && kUNOP->op_first->op_type == OP_GV)
8448 {
0bd48802 8449 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 8450 name = GvNAME(gv);
8451 len = GvNAMELEN(gv);
2dc9cdca 8452 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
2c8ac474 8453 }
afd1915d
GS		 8454 else if (kid->op_type == OP_AELEM
8455 || kid->op_type == OP_HELEM)
8456 {
735fec84 8457 OP *firstop;
551405c4 8458 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 8459 name = NULL;
551405c4 8460 if (op) {
a0714e2c 8461 SV *tmpstr = NULL;
551405c4 8462 const char * const a =
666ea192
JH		 8463 kid->op_type == OP_AELEM ?
8464 "[]" : "{}";
0c4b0a3f
JH		 8465 if (((op->op_type == OP_RV2AV) ||
8466 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 8467 (firstop = ((UNOP*)op)->op_first) &&
8468 (firstop->op_type == OP_GV)) {
0c4b0a3f 8469 /* packagevar $a[] or $h{} */
735fec84 8470 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 8471 if (gv)
8472 tmpstr =
8473 Perl_newSVpvf(aTHX_
8474 "%s%c...%c",
8475 GvNAME(gv),
8476 a[0], a[1]);
8477 }
8478 else if (op->op_type == OP_PADAV
8479 || op->op_type == OP_PADHV) {
8480 /* lexicalvar $a[] or $h{} */
551405c4 8481 const char * const padname =
0c4b0a3f
JH		 8482 PAD_COMPNAME_PV(op->op_targ);
8483 if (padname)
8484 tmpstr =
8485 Perl_newSVpvf(aTHX_
8486 "%s%c...%c",
8487 padname + 1,
8488 a[0], a[1]);
0c4b0a3f
JH		 8489 }
8490 if (tmpstr) {
93524f2b 8491 name = SvPV_const(tmpstr, len);
2dc9cdca 8492 name_utf8 = SvUTF8(tmpstr);
0c4b0a3f
JH		 8493 sv_2mortal(tmpstr);
8494 }
8495 }
8496 if (!name) {
8497 name = "__ANONIO__";
8498 len = 10;
885f468a 8499 want_dollar = FALSE;
0c4b0a3f 8500 }
3ad73efd 8501 op_lvalue(kid, type);
afd1915d 8502 }
2c8ac474
GS		 8503 if (name) {
8504 SV *namesv;
8505 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 8506 namesv = PAD_SVl(targ);
862a34c6 8507 SvUPGRADE(namesv, SVt_PV);
885f468a 8508 if (want_dollar && *name != '$')
76f68e9b 8509 sv_setpvs(namesv, "$");
2c8ac474 8510 sv_catpvn(namesv, name, len);
2dc9cdca 8511 if ( name_utf8 ) SvUTF8_on(namesv);
2c8ac474 8512 }
853846ea 8513 }
79072805 8514 kid->op_sibling = 0;
35cd451c 8515 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 8516 kid->op_targ = targ;
8517 kid->op_private |= priv;
79072805
LW		 8518 }
8519 kid->op_sibling = sibl;
8520 *tokid = kid;
8521 }
8522 scalar(kid);
8523 break;
8524 case OA_SCALARREF:
1efec5ed
FC		 8525 if ((type == OP_UNDEF || type == OP_POS)
8526 && numargs == 1 && !(oa >> 4)
89c5c07e
FC		 8527 && kid->op_type == OP_LIST)
8528 return too_many_arguments_pv(o,PL_op_desc[type], 0);
3ad73efd 8529 op_lvalue(scalar(kid), type);
79072805
LW		 8530 break;
8531 }
8532 oa >>= 4;
8533 tokid = &kid->op_sibling;
8534 kid = kid->op_sibling;
8535 }
eb8433b7
NC		 8536#ifdef PERL_MAD
8537 if (kid && kid->op_type != OP_STUB)
ce16c625 8538 return too_many_arguments_pv(o,OP_DESC(o), 0);
eb8433b7
NC		 8539 o->op_private |= numargs;
8540#else
8541 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 8542 o->op_private |= numargs;
79072805 8543 if (kid)
ce16c625 8544 return too_many_arguments_pv(o,OP_DESC(o), 0);
eb8433b7 8545#endif
11343788 8546 listkids(o);
79072805 8547 }
22c35a8c 8548 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 8549#ifdef PERL_MAD
c7fe699d 8550 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 8551 op_getmad(o,newop,'O');
c7fe699d 8552 return newop;
c56915e3 8553#else
c7fe699d 8554 /* Ordering of these two is important to keep f_map.t passing. */
11343788 8555 op_free(o);
c7fe699d 8556 return newUNOP(type, 0, newDEFSVOP());
c56915e3 8557#endif
a0d0e21e
LW		 8558 }
8559
79072805
LW		 8560 if (oa) {
8561 while (oa & OA_OPTIONAL)
8562 oa >>= 4;
8563 if (oa && oa != OA_LIST)
ce16c625 8564 return too_few_arguments_pv(o,OP_DESC(o), 0);
79072805 8565 }
11343788 8566 return o;
79072805
LW		 8567}
8568
8569OP *
cea2e8a9 8570Perl_ck_glob(pTHX_ OP *o)
79072805 8571{
27da23d5 8572 dVAR;
fb73857a 8573 GV *gv;
d67594ff 8574 const bool core = o->op_flags & OPf_SPECIAL;
fb73857a 8575
7918f24d
NC		 8576 PERL_ARGS_ASSERT_CK_GLOB;
8577
649da076 8578 o = ck_fun(o);
1f2bfc8a 8579 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
bd31915d 8580 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
fb73857a 8581
d67594ff
FC		 8582 if (core) gv = NULL;
8583 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 8584 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8585 {
8113e1cc
FC		 8586 GV * const * const gvp =
8587 (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
8588 gv = gvp ? *gvp : NULL;
b9f751c0 8589 }
b1cb66bf 8590
b9f751c0 8591 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
d1bea3d8
DM		 8592 /* convert
8593 * glob
8594 * \ null - const(wildcard)
8595 * into
8596 * null
8597 * \ enter
8598 * \ list
8599 * \ mark - glob - rv2cv
8600 * | \ gv(CORE::GLOBAL::glob)
8601 * |
8602 * \ null - const(wildcard) - const(ix)
8603 */
8604 o->op_flags |= OPf_SPECIAL;
9426e1a5 8605 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
2fcb4757 8606 op_append_elem(OP_GLOB, o,
80252599 8607 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
d1bea3d8 8608 o = newLISTOP(OP_LIST, 0, o, NULL);
1f2bfc8a 8609 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 8610 op_append_elem(OP_LIST, o,
1f2bfc8a
MB		 8611 scalar(newUNOP(OP_RV2CV, 0,
8612 newGVOP(OP_GV, 0, gv)))));
7ae76aaa 8613 o = newUNOP(OP_NULL, 0, o);
d1bea3d8 8614 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
d58bf5aa 8615 return o;
b1cb66bf 8616 }
d67594ff 8617 else o->op_flags &= ~OPf_SPECIAL;
39e3b1bc
FC		 8618#if !defined(PERL_EXTERNAL_GLOB)
8619 if (!PL_globhook) {
8620 ENTER;
8621 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8622 newSVpvs("File::Glob"), NULL, NULL, NULL);
8623 LEAVE;
8624 }
8625#endif /* !PERL_EXTERNAL_GLOB */
b1cb66bf 8626 gv = newGVgen("main");
a0d0e21e 8627 gv_IOadd(gv);
d67594ff
FC		 8628#ifndef PERL_EXTERNAL_GLOB
8629 sv_setiv(GvSVn(gv),PL_glob_index++);
8630#endif
2fcb4757 8631 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11343788 8632 scalarkids(o);
649da076 8633 return o;
79072805
LW		 8634}
8635
8636OP *
cea2e8a9 8637Perl_ck_grep(pTHX_ OP *o)
79072805 8638{
27da23d5 8639 dVAR;
03ca120d 8640 LOGOP *gwop = NULL;
79072805 8641 OP *kid;
6867be6d 8642 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 8643 PADOFFSET offset;
79072805 8644
7918f24d
NC		 8645 PERL_ARGS_ASSERT_CK_GREP;
8646
22c35a8c 8647 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 8648 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 8649
11343788 8650 if (o->op_flags & OPf_STACKED) {
a0d0e21e 8651 OP* k;
11343788 8652 o = ck_sort(o);
f6435df3
GG		 8653 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8654 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8655 return no_fh_allowed(o);
8656 for (k = kid; k; k = k->op_next) {
a0d0e21e
LW		 8657 kid = k;
8658 }
03ca120d 8659 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 8660 kid->op_next = (OP*)gwop;
11343788 8661 o->op_flags &= ~OPf_STACKED;
93a17b20 8662 }
11343788 8663 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 8664 if (type == OP_MAPWHILE)
8665 list(kid);
8666 else
8667 scalar(kid);
11343788 8668 o = ck_fun(o);
13765c85 8669 if (PL_parser && PL_parser->error_count)
11343788 8670 return o;
aeea060c 8671 kid = cLISTOPo->op_first->op_sibling;
79072805 8672 if (kid->op_type != OP_NULL)
5637ef5b 8673 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
79072805
LW		 8674 kid = kUNOP->op_first;
8675
03ca120d
MHM		 8676 if (!gwop)
8677 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 8678 gwop->op_type = type;
22c35a8c 8679 gwop->op_ppaddr = PL_ppaddr[type];
11343788 8680 gwop->op_first = listkids(o);
79072805 8681 gwop->op_flags |= OPf_KIDS;
79072805 8682 gwop->op_other = LINKLIST(kid);
79072805 8683 kid->op_next = (OP*)gwop;
cc76b5cc 8684 offset = pad_findmy_pvs("$_", 0);
00b1698f 8685 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 8686 o->op_private = gwop->op_private = 0;
8687 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8688 }
8689 else {
8690 o->op_private = gwop->op_private = OPpGREP_LEX;
8691 gwop->op_targ = o->op_targ = offset;
8692 }
79072805 8693
11343788 8694 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 8695 if (!kid || !kid->op_sibling)
ce16c625 8696 return too_few_arguments_pv(o,OP_DESC(o), 0);
a0d0e21e 8697 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 8698 op_lvalue(kid, OP_GREPSTART);
a0d0e21e 8699
79072805
LW		 8700 return (OP*)gwop;
8701}
8702
8703OP *
cea2e8a9 8704Perl_ck_index(pTHX_ OP *o)
79072805 8705{
7918f24d
NC		 8706 PERL_ARGS_ASSERT_CK_INDEX;
8707
11343788
MB		 8708 if (o->op_flags & OPf_KIDS) {
8709 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 8710 if (kid)
8711 kid = kid->op_sibling; /* get past "big" */
3b36395d
DM		 8712 if (kid && kid->op_type == OP_CONST) {
8713 const bool save_taint = PL_tainted;
2779dcf1 8714 fbm_compile(((SVOP*)kid)->op_sv, 0);
3b36395d
DM		 8715 PL_tainted = save_taint;
8716 }
79072805 8717 }
11343788 8718 return ck_fun(o);
79072805
LW		 8719}
8720
8721OP *
cea2e8a9 8722Perl_ck_lfun(pTHX_ OP *o)
79072805 8723{
6867be6d 8724 const OPCODE type = o->op_type;
7918f24d
NC		 8725
8726 PERL_ARGS_ASSERT_CK_LFUN;
8727
5dc0d613 8728 return modkids(ck_fun(o), type);
79072805
LW		 8729}
8730
8731OP *
cea2e8a9 8732Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 8733{
7918f24d
NC		 8734 PERL_ARGS_ASSERT_CK_DEFINED;
8735
a2a5de95 8736 if ((o->op_flags & OPf_KIDS)) {
d0334bed
GS		 8737 switch (cUNOPo->op_first->op_type) {
8738 case OP_RV2AV:
8739 case OP_PADAV:
8740 case OP_AASSIGN: /* Is this a good idea? */
d1d15184 8741 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8742 "defined(@array) is deprecated");
d1d15184 8743 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8744 "\t(Maybe you should just omit the defined()?)\n");
69794302 8745 break;
d0334bed
GS		 8746 case OP_RV2HV:
8747 case OP_PADHV:
d1d15184 8748 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8749 "defined(%%hash) is deprecated");
d1d15184 8750 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8751 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 8752 break;
8753 default:
8754 /* no warning */
8755 break;
8756 }
69794302
MJD		 8757 }
8758 return ck_rfun(o);
8759}
8760
8761OP *
e4b7ebf3
RGS		 8762Perl_ck_readline(pTHX_ OP *o)
8763{
7918f24d
NC		 8764 PERL_ARGS_ASSERT_CK_READLINE;
8765
b73e5385
FC		 8766 if (o->op_flags & OPf_KIDS) {
8767 OP *kid = cLISTOPo->op_first;
8768 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
8769 }
8770 else {
e4b7ebf3
RGS		 8771 OP * const newop
8772 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8773#ifdef PERL_MAD
8774 op_getmad(o,newop,'O');
8775#else
8776 op_free(o);
8777#endif
8778 return newop;
8779 }
8780 return o;
8781}
8782
8783OP *
cea2e8a9 8784Perl_ck_rfun(pTHX_ OP *o)
8990e307 8785{
6867be6d 8786 const OPCODE type = o->op_type;
7918f24d
NC		 8787
8788 PERL_ARGS_ASSERT_CK_RFUN;
8789
5dc0d613 8790 return refkids(ck_fun(o), type);
8990e307
LW		 8791}
8792
8793OP *
cea2e8a9 8794Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 8795{
8796 register OP *kid;
aeea060c 8797
7918f24d
NC		 8798 PERL_ARGS_ASSERT_CK_LISTIOB;
8799
11343788 8800 kid = cLISTOPo->op_first;
79072805 8801 if (!kid) {
11343788
MB		 8802 o = force_list(o);
8803 kid = cLISTOPo->op_first;
79072805
LW		 8804 }
8805 if (kid->op_type == OP_PUSHMARK)
8806 kid = kid->op_sibling;
11343788 8807 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 8808 kid = kid->op_sibling;
8809 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8810 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 8811 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 8812 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 8813 cLISTOPo->op_first->op_sibling = kid;
8814 cLISTOPo->op_last = kid;
79072805
LW		 8815 kid = kid->op_sibling;
8816 }
8817 }
b2ffa427 8818
79072805 8819 if (!kid)
2fcb4757 8820 op_append_elem(o->op_type, o, newDEFSVOP());
79072805 8821
69974ce6 8822 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
2de3dbcc 8823 return listkids(o);
bbce6d69 8824}
8825
8826OP *
0d863452
RH		 8827Perl_ck_smartmatch(pTHX_ OP *o)
8828{
97aff369 8829 dVAR;
a4e74480 8830 PERL_ARGS_ASSERT_CK_SMARTMATCH;
0d863452
RH		 8831 if (0 == (o->op_flags & OPf_SPECIAL)) {
8832 OP *first = cBINOPo->op_first;
8833 OP *second = first->op_sibling;
8834
8835 /* Implicitly take a reference to an array or hash */
5f66b61c 8836 first->op_sibling = NULL;
0d863452
RH		 8837 first = cBINOPo->op_first = ref_array_or_hash(first);
8838 second = first->op_sibling = ref_array_or_hash(second);
8839
8840 /* Implicitly take a reference to a regular expression */
8841 if (first->op_type == OP_MATCH) {
8842 first->op_type = OP_QR;
8843 first->op_ppaddr = PL_ppaddr[OP_QR];
8844 }
8845 if (second->op_type == OP_MATCH) {
8846 second->op_type = OP_QR;
8847 second->op_ppaddr = PL_ppaddr[OP_QR];
8848 }
8849 }
8850
8851 return o;
8852}
8853
8854
8855OP *
b162f9ea
IZ		 8856Perl_ck_sassign(pTHX_ OP *o)
8857{
3088bf26 8858 dVAR;
1496a290 8859 OP * const kid = cLISTOPo->op_first;
7918f24d
NC		 8860
8861 PERL_ARGS_ASSERT_CK_SASSIGN;
8862
b162f9ea
IZ		 8863 /* has a disposable target? */
8864 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 8865 && !(kid->op_flags & OPf_STACKED)
8866 /* Cannot steal the second time! */
1b438339
GG		 8867 && !(kid->op_private & OPpTARGET_MY)
8868 /* Keep the full thing for madskills */
8869 && !PL_madskills
8870 )
b162f9ea 8871 {
551405c4 8872 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 8873
8874 /* Can just relocate the target. */
2c2d71f5
JH		 8875 if (kkid && kkid->op_type == OP_PADSV
8876 && !(kkid->op_private & OPpLVAL_INTRO))
8877 {
b162f9ea 8878 kid->op_targ = kkid->op_targ;
743e66e6 8879 kkid->op_targ = 0;
b162f9ea
IZ		 8880 /* Now we do not need PADSV and SASSIGN. */
8881 kid->op_sibling = o->op_sibling; /* NULL */
8882 cLISTOPo->op_first = NULL;
8883 op_free(o);
8884 op_free(kkid);
8885 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8886 return kid;
8887 }
8888 }
c5917253
NC		 8889 if (kid->op_sibling) {
8890 OP *kkid = kid->op_sibling;
a1fba7eb
FC		 8891 /* For state variable assignment, kkid is a list op whose op_last
8892 is a padsv. */
8893 if ((kkid->op_type == OP_PADSV ||
8894 (kkid->op_type == OP_LIST &&
8895 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8896 )
8897 )
c5917253
NC		 8898 && (kkid->op_private & OPpLVAL_INTRO)
8899 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8900 const PADOFFSET target = kkid->op_targ;
8901 OP *const other = newOP(OP_PADSV,
8902 kkid->op_flags
8903 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8904 OP *const first = newOP(OP_NULL, 0);
8905 OP *const nullop = newCONDOP(0, first, o, other);
8906 OP *const condop = first->op_next;
8907 /* hijacking PADSTALE for uninitialized state variables */
8908 SvPADSTALE_on(PAD_SVl(target));
8909
8910 condop->op_type = OP_ONCE;
8911 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8912 condop->op_targ = target;
8913 other->op_targ = target;
8914
95562366 8915 /* Because we change the type of the op here, we will skip the
486ec47a 8916 assignment binop->op_last = binop->op_first->op_sibling; at the
95562366
NC		 8917 end of Perl_newBINOP(). So need to do it here. */
8918 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8919
c5917253
NC		 8920 return nullop;
8921 }
8922 }
b162f9ea
IZ		 8923 return o;
8924}
8925
8926OP *
cea2e8a9 8927Perl_ck_match(pTHX_ OP *o)
79072805 8928{
97aff369 8929 dVAR;
7918f24d
NC		 8930
8931 PERL_ARGS_ASSERT_CK_MATCH;
8932
0d863452 8933 if (o->op_type != OP_QR && PL_compcv) {
cc76b5cc 8934 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 8935 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 8936 o->op_targ = offset;
8937 o->op_private |= OPpTARGET_MY;
8938 }
8939 }
8940 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8941 o->op_private |= OPpRUNTIME;
11343788 8942 return o;
79072805
LW		 8943}
8944
8945OP *
f5d5a27c
CS		 8946Perl_ck_method(pTHX_ OP *o)
8947{
551405c4 8948 OP * const kid = cUNOPo->op_first;
7918f24d
NC		 8949
8950 PERL_ARGS_ASSERT_CK_METHOD;
8951
f5d5a27c
CS		 8952 if (kid->op_type == OP_CONST) {
8953 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 8954 const char * const method = SvPVX_const(sv);
8955 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 8956 OP *cmop;
1c846c1f 8957 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
c60dbbc3 8958 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
1c846c1f
NIS		 8959 }
8960 else {
a0714e2c 8961 kSVOP->op_sv = NULL;
1c846c1f 8962 }
f5d5a27c 8963 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 8964#ifdef PERL_MAD
8965 op_getmad(o,cmop,'O');
8966#else
f5d5a27c 8967 op_free(o);
eb8433b7 8968#endif
f5d5a27c
CS		 8969 return cmop;
8970 }
8971 }
8972 return o;
8973}
8974
8975OP *
cea2e8a9 8976Perl_ck_null(pTHX_ OP *o)
79072805 8977{
7918f24d 8978 PERL_ARGS_ASSERT_CK_NULL;
96a5add6 8979 PERL_UNUSED_CONTEXT;
11343788 8980 return o;
79072805
LW		 8981}
8982
8983OP *
16fe6d59
GS		 8984Perl_ck_open(pTHX_ OP *o)
8985{
97aff369 8986 dVAR;
551405c4 8987 HV * const table = GvHV(PL_hintgv);
7918f24d
NC		 8988
8989 PERL_ARGS_ASSERT_CK_OPEN;
8990
16fe6d59 8991 if (table) {
a4fc7abc 8992 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 8993 if (svp && *svp) {
a79b25b7
VP		 8994 STRLEN len = 0;
8995 const char *d = SvPV_const(*svp, len);
8996 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 8997 if (mode & O_BINARY)
8998 o->op_private |= OPpOPEN_IN_RAW;
8999 else if (mode & O_TEXT)
9000 o->op_private |= OPpOPEN_IN_CRLF;
9001 }
9002
a4fc7abc 9003 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 9004 if (svp && *svp) {
a79b25b7
VP		 9005 STRLEN len = 0;
9006 const char *d = SvPV_const(*svp, len);
9007 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 9008 if (mode & O_BINARY)
9009 o->op_private |= OPpOPEN_OUT_RAW;
9010 else if (mode & O_TEXT)
9011 o->op_private |= OPpOPEN_OUT_CRLF;
9012 }
9013 }
8d7403e6
RGS		 9014 if (o->op_type == OP_BACKTICK) {
9015 if (!(o->op_flags & OPf_KIDS)) {
e4b7ebf3
RGS		 9016 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9017#ifdef PERL_MAD
9018 op_getmad(o,newop,'O');
9019#else
8d7403e6 9020 op_free(o);
e4b7ebf3
RGS		 9021#endif
9022 return newop;
8d7403e6 9023 }
16fe6d59 9024 return o;
8d7403e6 9025 }
3b82e551
JH		 9026 {
9027 /* In case of three-arg dup open remove strictness
9028 * from the last arg if it is a bareword. */
551405c4
AL		 9029 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9030 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 9031 OP *oa;
b15aece3 9032 const char *mode;
3b82e551
JH		 9033
9034 if ((last->op_type == OP_CONST) && /* The bareword. */
9035 (last->op_private & OPpCONST_BARE) &&
9036 (last->op_private & OPpCONST_STRICT) &&
9037 (oa = first->op_sibling) && /* The fh. */
9038 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 9039 (oa->op_type == OP_CONST) &&
3b82e551 9040 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 9041 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 9042 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9043 (last == oa->op_sibling)) /* The bareword. */
9044 last->op_private &= ~OPpCONST_STRICT;
9045 }
16fe6d59
GS		 9046 return ck_fun(o);
9047}
9048
9049OP *
cea2e8a9 9050Perl_ck_repeat(pTHX_ OP *o)
79072805 9051{
7918f24d
NC		 9052 PERL_ARGS_ASSERT_CK_REPEAT;
9053
11343788
MB		 9054 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9055 o->op_private |= OPpREPEAT_DOLIST;
9056 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 9057 }
9058 else
11343788
MB		 9059 scalar(o);
9060 return o;
79072805
LW		 9061}
9062
9063OP *
cea2e8a9 9064Perl_ck_require(pTHX_ OP *o)
8990e307 9065{
97aff369 9066 dVAR;
a0714e2c 9067 GV* gv = NULL;
ec4ab249 9068
7918f24d
NC		 9069 PERL_ARGS_ASSERT_CK_REQUIRE;
9070
11343788 9071 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 9072 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 9073
9074 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 9075 SV * const sv = kid->op_sv;
5c144d81 9076 U32 was_readonly = SvREADONLY(sv);
8990e307 9077 char *s;
cfff9797
NC		 9078 STRLEN len;
9079 const char *end;
5c144d81
NC		 9080
9081 if (was_readonly) {
9082 if (SvFAKE(sv)) {
9083 sv_force_normal_flags(sv, 0);
9084 assert(!SvREADONLY(sv));
9085 was_readonly = 0;
9086 } else {
9087 SvREADONLY_off(sv);
9088 }
9089 }
9090
cfff9797
NC		 9091 s = SvPVX(sv);
9092 len = SvCUR(sv);
9093 end = s + len;
9094 for (; s < end; s++) {
a0d0e21e
LW		 9095 if (*s == ':' && s[1] == ':') {
9096 *s = '/';
5c6b2528 9097 Move(s+2, s+1, end - s - 1, char);
cfff9797 9098 --end;
a0d0e21e 9099 }
8990e307 9100 }
cfff9797 9101 SvEND_set(sv, end);
396482e1 9102 sv_catpvs(sv, ".pm");
5c144d81 9103 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 9104 }
9105 }
ec4ab249 9106
a72a1c8b
RGS		 9107 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
9108 /* handle override, if any */
fafc274c 9109 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 9110 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 9111 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 9112 gv = gvp ? *gvp : NULL;
d6a985f2 9113 }
a72a1c8b 9114 }
ec4ab249 9115
b9f751c0 9116 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7c864bb3
VP		 9117 OP *kid, *newop;
9118 if (o->op_flags & OPf_KIDS) {
9119 kid = cUNOPo->op_first;
9120 cUNOPo->op_first = NULL;
9121 }
9122 else {
9123 kid = newDEFSVOP();
9124 }
f11453cb 9125#ifndef PERL_MAD
ec4ab249 9126 op_free(o);
eb8433b7 9127#endif
d1bef648 9128 newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 9129 op_append_elem(OP_LIST, kid,
f11453cb
NC		 9130 scalar(newUNOP(OP_RV2CV, 0,
9131 newGVOP(OP_GV, 0,
d1bef648 9132 gv)))));
f11453cb 9133 op_getmad(o,newop,'O');
eb8433b7 9134 return newop;
ec4ab249
GA		 9135 }
9136
021f53de 9137 return scalar(ck_fun(o));
8990e307
LW		 9138}
9139
78f9721b
SM		 9140OP *
9141Perl_ck_return(pTHX_ OP *o)
9142{
97aff369 9143 dVAR;
e91684bf 9144 OP *kid;
7918f24d
NC		 9145
9146 PERL_ARGS_ASSERT_CK_RETURN;
9147
e91684bf 9148 kid = cLISTOPo->op_first->op_sibling;
78f9721b 9149 if (CvLVALUE(PL_compcv)) {
e91684bf 9150 for (; kid; kid = kid->op_sibling)
3ad73efd 9151 op_lvalue(kid, OP_LEAVESUBLV);
78f9721b 9152 }
e91684bf 9153
78f9721b
SM		 9154 return o;
9155}
9156
79072805 9157OP *
cea2e8a9 9158Perl_ck_select(pTHX_ OP *o)
79072805 9159{
27da23d5 9160 dVAR;
c07a80fd 9161 OP* kid;
7918f24d
NC		 9162
9163 PERL_ARGS_ASSERT_CK_SELECT;
9164
11343788
MB		 9165 if (o->op_flags & OPf_KIDS) {
9166 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 9167 if (kid && kid->op_sibling) {
11343788 9168 o->op_type = OP_SSELECT;
22c35a8c 9169 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788 9170 o = ck_fun(o);
985b9e54 9171 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 9172 }
9173 }
11343788
MB		 9174 o = ck_fun(o);
9175 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 9176 if (kid && kid->op_type == OP_RV2GV)
9177 kid->op_private &= ~HINT_STRICT_REFS;
11343788 9178 return o;
79072805
LW		 9179}
9180
9181OP *
cea2e8a9 9182Perl_ck_shift(pTHX_ OP *o)
79072805 9183{
97aff369 9184 dVAR;
6867be6d 9185 const I32 type = o->op_type;
79072805 9186
7918f24d
NC		 9187 PERL_ARGS_ASSERT_CK_SHIFT;
9188
11343788 9189 if (!(o->op_flags & OPf_KIDS)) {
538f5756
RZ		 9190 OP *argop;
9191
9192 if (!CvUNIQUE(PL_compcv)) {
9193 o->op_flags |= OPf_SPECIAL;
9194 return o;
9195 }
9196
9197 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
eb8433b7 9198#ifdef PERL_MAD
790427a5
DM		 9199 {
9200 OP * const oldo = o;
9201 o = newUNOP(type, 0, scalar(argop));
9202 op_getmad(oldo,o,'O');
9203 return o;
9204 }
eb8433b7 9205#else
821005df 9206 op_free(o);
6d4ff0d2 9207 return newUNOP(type, 0, scalar(argop));
eb8433b7 9208#endif
79072805 9209 }
d4fc4415 9210 return scalar(ck_fun(o));
79072805
LW		 9211}
9212
9213OP *
cea2e8a9 9214Perl_ck_sort(pTHX_ OP *o)
79072805 9215{
97aff369 9216 dVAR;
8e3f9bdf 9217 OP *firstkid;
bbce6d69 9218
7918f24d
NC		 9219 PERL_ARGS_ASSERT_CK_SORT;
9220
1496a290 9221 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
a4fc7abc 9222 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 9223 if (hinthv) {
a4fc7abc 9224 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 9225 if (svp) {
a4fc7abc 9226 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 9227 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9228 o->op_private |= OPpSORT_QSORT;
9229 if ((sorthints & HINT_SORT_STABLE) != 0)
9230 o->op_private |= OPpSORT_STABLE;
9231 }
9232 }
9233 }
9234
9ea6e965 9235 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 9236 simplify_sort(o);
8e3f9bdf
GS		 9237 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9238 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 9239 OP *k = NULL;
8e3f9bdf 9240 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 9241
463ee0b2 9242 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5983a79d 9243 LINKLIST(kid);
463ee0b2
LW		 9244 if (kid->op_type == OP_SCOPE) {
9245 k = kid->op_next;
9246 kid->op_next = 0;
79072805 9247 }
463ee0b2 9248 else if (kid->op_type == OP_LEAVE) {
11343788 9249 if (o->op_type == OP_SORT) {
93c66552 9250 op_null(kid); /* wipe out leave */
748a9306 9251 kid->op_next = kid;
463ee0b2 9252
748a9306
LW		 9253 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
9254 if (k->op_next == kid)
9255 k->op_next = 0;
71a29c3c
GS		 9256 /* don't descend into loops */
9257 else if (k->op_type == OP_ENTERLOOP
9258 || k->op_type == OP_ENTERITER)
9259 {
9260 k = cLOOPx(k)->op_lastop;
9261 }
748a9306 9262 }
463ee0b2 9263 }
748a9306
LW		 9264 else
9265 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 9266 k = kLISTOP->op_first;
463ee0b2 9267 }
a2efc822 9268 CALL_PEEP(k);
a0d0e21e 9269
8e3f9bdf
GS		 9270 kid = firstkid;
9271 if (o->op_type == OP_SORT) {
9272 /* provide scalar context for comparison function/block */
9273 kid = scalar(kid);
a0d0e21e 9274 kid->op_next = kid;
8e3f9bdf 9275 }
a0d0e21e
LW		 9276 else
9277 kid->op_next = k;
11343788 9278 o->op_flags |= OPf_SPECIAL;
79072805 9279 }
8e3f9bdf
GS		 9280
9281 firstkid = firstkid->op_sibling;
79072805 9282 }
bbce6d69 9283
8e3f9bdf
GS		 9284 /* provide list context for arguments */
9285 if (o->op_type == OP_SORT)
9286 list(firstkid);
9287
11343788 9288 return o;
79072805 9289}
bda4119b
GS		 9290
9291STATIC void
cea2e8a9 9292S_simplify_sort(pTHX_ OP *o)
9c007264 9293{
97aff369 9294 dVAR;
9c007264
JH		 9295 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9296 OP *k;
eb209983 9297 int descending;
350de78d 9298 GV *gv;
770526c1 9299 const char *gvname;
7918f24d
NC		 9300
9301 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9302
9c007264
JH		 9303 if (!(o->op_flags & OPf_STACKED))
9304 return;
fafc274c
NC		 9305 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9306 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 9307 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 9308 if (kid->op_type != OP_SCOPE)
9309 return;
9310 kid = kLISTOP->op_last; /* get past scope */
9311 switch(kid->op_type) {
9312 case OP_NCMP:
9313 case OP_I_NCMP:
9314 case OP_SCMP:
9315 break;
9316 default:
9317 return;
9318 }
9319 k = kid; /* remember this node*/
9320 if (kBINOP->op_first->op_type != OP_RV2SV)
9321 return;
9322 kid = kBINOP->op_first; /* get past cmp */
9323 if (kUNOP->op_first->op_type != OP_GV)
9324 return;
9325 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 9326 gv = kGVOP_gv;
350de78d 9327 if (GvSTASH(gv) != PL_curstash)
9c007264 9328 return;
770526c1
NC		 9329 gvname = GvNAME(gv);
9330 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 9331 descending = 0;
770526c1 9332 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 9333 descending = 1;
9c007264
JH		 9334 else
9335 return;
eb209983 9336
9c007264
JH		 9337 kid = k; /* back to cmp */
9338 if (kBINOP->op_last->op_type != OP_RV2SV)
9339 return;
9340 kid = kBINOP->op_last; /* down to 2nd arg */
9341 if (kUNOP->op_first->op_type != OP_GV)
9342 return;
9343 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 9344 gv = kGVOP_gv;
770526c1
NC		 9345 if (GvSTASH(gv) != PL_curstash)
9346 return;
9347 gvname = GvNAME(gv);
9348 if ( descending
9349 ? !(*gvname == 'a' && gvname[1] == '\0')
9350 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 9351 return;
9352 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 9353 if (descending)
9354 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 9355 if (k->op_type == OP_NCMP)
9356 o->op_private |= OPpSORT_NUMERIC;
9357 if (k->op_type == OP_I_NCMP)
9358 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 9359 kid = cLISTOPo->op_first->op_sibling;
9360 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 9361#ifdef PERL_MAD
9362 op_getmad(kid,o,'S'); /* then delete it */
9363#else
e507f050 9364 op_free(kid); /* then delete it */
eb8433b7 9365#endif
9c007264 9366}
79072805
LW		 9367
9368OP *
cea2e8a9 9369Perl_ck_split(pTHX_ OP *o)
79072805 9370{
27da23d5 9371 dVAR;
79072805 9372 register OP *kid;
aeea060c 9373
7918f24d
NC		 9374 PERL_ARGS_ASSERT_CK_SPLIT;
9375
11343788
MB		 9376 if (o->op_flags & OPf_STACKED)
9377 return no_fh_allowed(o);
79072805 9378
11343788 9379 kid = cLISTOPo->op_first;
8990e307 9380 if (kid->op_type != OP_NULL)
5637ef5b 9381 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
8990e307 9382 kid = kid->op_sibling;
11343788 9383 op_free(cLISTOPo->op_first);
f126b75f
MW		 9384 if (kid)
9385 cLISTOPo->op_first = kid;
9386 else {
396482e1 9387 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 9388 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 9389 }
79072805 9390
de4bf5b3 9391 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 9392 OP * const sibl = kid->op_sibling;
463ee0b2 9393 kid->op_sibling = 0;
d63c20f2 9394 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
11343788
MB		 9395 if (cLISTOPo->op_first == cLISTOPo->op_last)
9396 cLISTOPo->op_last = kid;
9397 cLISTOPo->op_first = kid;
79072805
LW		 9398 kid->op_sibling = sibl;
9399 }
9400
9401 kid->op_type = OP_PUSHRE;
22c35a8c 9402 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 9403 scalar(kid);
a2a5de95
NC		 9404 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9405 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9406 "Use of /g modifier is meaningless in split");
f34840d8 9407 }
79072805
LW		 9408
9409 if (!kid->op_sibling)
2fcb4757 9410 op_append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 9411
9412 kid = kid->op_sibling;
9413 scalar(kid);
9414
9415 if (!kid->op_sibling)
2fcb4757 9416 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
ce3e5c45 9417 assert(kid->op_sibling);
79072805
LW		 9418
9419 kid = kid->op_sibling;
9420 scalar(kid);
9421
9422 if (kid->op_sibling)
ce16c625 9423 return too_many_arguments_pv(o,OP_DESC(o), 0);
79072805 9424
11343788 9425 return o;
79072805
LW		 9426}
9427
9428OP *
1c846c1f 9429Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 9430{
551405c4 9431 const OP * const kid = cLISTOPo->op_first->op_sibling;
7918f24d
NC		 9432
9433 PERL_ARGS_ASSERT_CK_JOIN;
9434
041457d9
DM		 9435 if (kid && kid->op_type == OP_MATCH) {
9436 if (ckWARN(WARN_SYNTAX)) {
6867be6d 9437 const REGEXP *re = PM_GETRE(kPMOP);
ce16c625
BF		 9438 const SV *msg = re
9439 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9440 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9441 : newSVpvs_flags( "STRING", SVs_TEMP );
9014280d 9442 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
ce16c625
BF		 9443 "/%"SVf"/ should probably be written as \"%"SVf"\"",
9444 SVfARG(msg), SVfARG(msg));
eb6e2d6f
GS		 9445 }
9446 }
9447 return ck_fun(o);
9448}
9449
d9088386
Z		 9450/*
9451=for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9452
9453Examines an op, which is expected to identify a subroutine at runtime,
9454and attempts to determine at compile time which subroutine it identifies.
9455This is normally used during Perl compilation to determine whether
9456a prototype can be applied to a function call. I<cvop> is the op
9457being considered, normally an C<rv2cv> op. A pointer to the identified
9458subroutine is returned, if it could be determined statically, and a null
9459pointer is returned if it was not possible to determine statically.
9460
9461Currently, the subroutine can be identified statically if the RV that the
9462C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9463A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
9464suitable if the constant value must be an RV pointing to a CV. Details of
9465this process may change in future versions of Perl. If the C<rv2cv> op
9466has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9467the subroutine statically: this flag is used to suppress compile-time
9468magic on a subroutine call, forcing it to use default runtime behaviour.
9469
9470If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9471of a GV reference is modified. If a GV was examined and its CV slot was
9472found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9473If the op is not optimised away, and the CV slot is later populated with
9474a subroutine having a prototype, that flag eventually triggers the warning
9475"called too early to check prototype".
9476
9477If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9478of returning a pointer to the subroutine it returns a pointer to the
9479GV giving the most appropriate name for the subroutine in this context.
9480Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9481(C<CvANON>) subroutine that is referenced through a GV it will be the
9482referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
9483A null pointer is returned as usual if there is no statically-determinable
9484subroutine.
7918f24d 9485
d9088386
Z		 9486=cut
9487*/
9d88f058 9488
d9088386
Z		 9489CV *
9490Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9491{
9492 OP *rvop;
9493 CV *cv;
9494 GV *gv;
9495 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9496 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9497 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9498 if (cvop->op_type != OP_RV2CV)
9499 return NULL;
9500 if (cvop->op_private & OPpENTERSUB_AMPER)
9501 return NULL;
9502 if (!(cvop->op_flags & OPf_KIDS))
9503 return NULL;
9504 rvop = cUNOPx(cvop)->op_first;
9505 switch (rvop->op_type) {
9506 case OP_GV: {
9507 gv = cGVOPx_gv(rvop);
9508 cv = GvCVu(gv);
9509 if (!cv) {
9510 if (flags & RV2CVOPCV_MARK_EARLY)
9511 rvop->op_private |= OPpEARLY_CV;
9512 return NULL;
46fc3d4c 9513 }
d9088386
Z		 9514 } break;
9515 case OP_CONST: {
9516 SV *rv = cSVOPx_sv(rvop);
9517 if (!SvROK(rv))
9518 return NULL;
9519 cv = (CV*)SvRV(rv);
9520 gv = NULL;
9521 } break;
9522 default: {
9523 return NULL;
9524 } break;
4633a7c4 9525 }
d9088386
Z		 9526 if (SvTYPE((SV*)cv) != SVt_PVCV)
9527 return NULL;
9528 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9529 if (!CvANON(cv) || !gv)
9530 gv = CvGV(cv);
9531 return (CV*)gv;
9532 } else {
9533 return cv;
7a52d87a 9534 }
d9088386 9535}
9d88f058 9536
d9088386
Z		 9537/*
9538=for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
824afba1 9539
d9088386
Z		 9540Performs the default fixup of the arguments part of an C<entersub>
9541op tree. This consists of applying list context to each of the
9542argument ops. This is the standard treatment used on a call marked
9543with C<&>, or a method call, or a call through a subroutine reference,
9544or any other call where the callee can't be identified at compile time,
9545or a call where the callee has no prototype.
824afba1 9546
d9088386
Z		 9547=cut
9548*/
340458b5 9549
d9088386
Z		 9550OP *
9551Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9552{
9553 OP *aop;
9554 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9555 aop = cUNOPx(entersubop)->op_first;
9556 if (!aop->op_sibling)
9557 aop = cUNOPx(aop)->op_first;
9558 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9559 if (!(PL_madskills && aop->op_type == OP_STUB)) {
9560 list(aop);
3ad73efd 9561 op_lvalue(aop, OP_ENTERSUB);
d9088386
Z		 9562 }
9563 }
9564 return entersubop;
9565}
340458b5 9566
d9088386
Z		 9567/*
9568=for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9569
9570Performs the fixup of the arguments part of an C<entersub> op tree
9571based on a subroutine prototype. This makes various modifications to
9572the argument ops, from applying context up to inserting C<refgen> ops,
9573and checking the number and syntactic types of arguments, as directed by
9574the prototype. This is the standard treatment used on a subroutine call,
9575not marked with C<&>, where the callee can be identified at compile time
9576and has a prototype.
9577
9578I<protosv> supplies the subroutine prototype to be applied to the call.
9579It may be a normal defined scalar, of which the string value will be used.
9580Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9581that has been cast to C<SV*>) which has a prototype. The prototype
9582supplied, in whichever form, does not need to match the actual callee
9583referenced by the op tree.
9584
9585If the argument ops disagree with the prototype, for example by having
9586an unacceptable number of arguments, a valid op tree is returned anyway.
9587The error is reflected in the parser state, normally resulting in a single
9588exception at the top level of parsing which covers all the compilation
9589errors that occurred. In the error message, the callee is referred to
9590by the name defined by the I<namegv> parameter.
cbf82dd0 9591
d9088386
Z		 9592=cut
9593*/
9594
9595OP *
9596Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9597{
9598 STRLEN proto_len;
9599 const char *proto, *proto_end;
9600 OP *aop, *prev, *cvop;
9601 int optional = 0;
9602 I32 arg = 0;
9603 I32 contextclass = 0;
9604 const char *e = NULL;
9605 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9606 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
cb197492 9607 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
5637ef5b 9608 "flags=%lx", (unsigned long) SvFLAGS(protosv));
8fa6a409
FC		 9609 if (SvTYPE(protosv) == SVt_PVCV)
9610 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9611 else proto = SvPV(protosv, proto_len);
d9088386
Z		 9612 proto_end = proto + proto_len;
9613 aop = cUNOPx(entersubop)->op_first;
9614 if (!aop->op_sibling)
9615 aop = cUNOPx(aop)->op_first;
9616 prev = aop;
9617 aop = aop->op_sibling;
9618 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9619 while (aop != cvop) {
9620 OP* o3;
9621 if (PL_madskills && aop->op_type == OP_STUB) {
9622 aop = aop->op_sibling;
9623 continue;
9624 }
9625 if (PL_madskills && aop->op_type == OP_NULL)
9626 o3 = ((UNOP*)aop)->op_first;
9627 else
9628 o3 = aop;
9629
9630 if (proto >= proto_end)
ce16c625 9631 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
d9088386
Z		 9632
9633 switch (*proto) {
597dcb2b
DG		 9634 case ';':
9635 optional = 1;
9636 proto++;
9637 continue;
9638 case '_':
9639 /* _ must be at the end */
34daab0f 9640 if (proto[1] && !strchr(";@%", proto[1]))
597dcb2b
DG		 9641 goto oops;
9642 case '$':
9643 proto++;
9644 arg++;
9645 scalar(aop);
9646 break;
9647 case '%':
9648 case '@':
9649 list(aop);
9650 arg++;
9651 break;
9652 case '&':
9653 proto++;
9654 arg++;
9655 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
ce16c625 9656 bad_type_sv(arg,
597dcb2b 9657 arg == 1 ? "block or sub {}" : "sub {}",
ce16c625 9658 gv_ename(namegv), 0, o3);
597dcb2b
DG		 9659 break;
9660 case '*':
9661 /* '*' allows any scalar type, including bareword */
9662 proto++;
9663 arg++;
9664 if (o3->op_type == OP_RV2GV)
9665 goto wrapref; /* autoconvert GLOB -> GLOBref */
9666 else if (o3->op_type == OP_CONST)
9667 o3->op_private &= ~OPpCONST_STRICT;
9668 else if (o3->op_type == OP_ENTERSUB) {
9669 /* accidental subroutine, revert to bareword */
9670 OP *gvop = ((UNOP*)o3)->op_first;
9671 if (gvop && gvop->op_type == OP_NULL) {
9672 gvop = ((UNOP*)gvop)->op_first;
9673 if (gvop) {
9674 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9675 ;
9676 if (gvop &&
9677 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9678 (gvop = ((UNOP*)gvop)->op_first) &&
9679 gvop->op_type == OP_GV)
9680 {
9681 GV * const gv = cGVOPx_gv(gvop);
9682 OP * const sibling = aop->op_sibling;
9683 SV * const n = newSVpvs("");
eb8433b7 9684#ifdef PERL_MAD
597dcb2b 9685 OP * const oldaop = aop;
eb8433b7 9686#else
597dcb2b 9687 op_free(aop);
eb8433b7 9688#endif
597dcb2b
DG		 9689 gv_fullname4(n, gv, "", FALSE);
9690 aop = newSVOP(OP_CONST, 0, n);
9691 op_getmad(oldaop,aop,'O');
9692 prev->op_sibling = aop;
9693 aop->op_sibling = sibling;
9694 }
9675f7ac
GS		 9695 }
9696 }
9697 }
597dcb2b 9698 scalar(aop);
c035a075
DG		 9699 break;
9700 case '+':
9701 proto++;
9702 arg++;
9703 if (o3->op_type == OP_RV2AV ||
9704 o3->op_type == OP_PADAV ||
9705 o3->op_type == OP_RV2HV ||
9706 o3->op_type == OP_PADHV
9707 ) {
9708 goto wrapref;
9709 }
9710 scalar(aop);
d9088386 9711 break;
597dcb2b
DG		 9712 case '[': case ']':
9713 goto oops;
d9088386 9714 break;
597dcb2b
DG		 9715 case '\\':
9716 proto++;
9717 arg++;
9718 again:
9719 switch (*proto++) {
9720 case '[':
9721 if (contextclass++ == 0) {
9722 e = strchr(proto, ']');
9723 if (!e || e == proto)
9724 goto oops;
9725 }
9726 else
9727 goto oops;
9728 goto again;
9729 break;
9730 case ']':
9731 if (contextclass) {
9732 const char *p = proto;
9733 const char *const end = proto;
9734 contextclass = 0;
062678b2
FC		 9735 while (*--p != '[')
9736 /* \[$] accepts any scalar lvalue */
9737 if (*p == '$'
9738 && Perl_op_lvalue_flags(aTHX_
9739 scalar(o3),
9740 OP_READ, /* not entersub */
9741 OP_LVALUE_NO_CROAK
9742 )) goto wrapref;
ce16c625 9743 bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
597dcb2b 9744 (int)(end - p), p),
ce16c625 9745 gv_ename(namegv), 0, o3);
597dcb2b
DG		 9746 } else
9747 goto oops;
9748 break;
9749 case '*':
9750 if (o3->op_type == OP_RV2GV)
9751 goto wrapref;
9752 if (!contextclass)
ce16c625 9753 bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
597dcb2b
DG		 9754 break;
9755 case '&':
9756 if (o3->op_type == OP_ENTERSUB)
9757 goto wrapref;
9758 if (!contextclass)
ce16c625 9759 bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
597dcb2b
DG		 9760 o3);
9761 break;
9762 case '$':
9763 if (o3->op_type == OP_RV2SV ||
9764 o3->op_type == OP_PADSV ||
9765 o3->op_type == OP_HELEM ||
9766 o3->op_type == OP_AELEM)
9767 goto wrapref;
062678b2
FC		 9768 if (!contextclass) {
9769 /* \$ accepts any scalar lvalue */
9770 if (Perl_op_lvalue_flags(aTHX_
9771 scalar(o3),
9772 OP_READ, /* not entersub */
9773 OP_LVALUE_NO_CROAK
9774 )) goto wrapref;
ce16c625 9775 bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
062678b2 9776 }
597dcb2b
DG		 9777 break;
9778 case '@':
9779 if (o3->op_type == OP_RV2AV ||
9780 o3->op_type == OP_PADAV)
9781 goto wrapref;
9782 if (!contextclass)
ce16c625 9783 bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
597dcb2b
DG		 9784 break;
9785 case '%':
9786 if (o3->op_type == OP_RV2HV ||
9787 o3->op_type == OP_PADHV)
9788 goto wrapref;
9789 if (!contextclass)
ce16c625 9790 bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
597dcb2b
DG		 9791 break;
9792 wrapref:
9793 {
9794 OP* const kid = aop;
9795 OP* const sib = kid->op_sibling;
9796 kid->op_sibling = 0;
9797 aop = newUNOP(OP_REFGEN, 0, kid);
9798 aop->op_sibling = sib;
9799 prev->op_sibling = aop;
9800 }
9801 if (contextclass && e) {
9802 proto = e + 1;
9803 contextclass = 0;
9804 }
9805 break;
9806 default: goto oops;
4633a7c4 9807 }
597dcb2b
DG		 9808 if (contextclass)
9809 goto again;
4633a7c4 9810 break;
597dcb2b
DG		 9811 case ' ':
9812 proto++;
9813 continue;
9814 default:
108f32a5
BF		 9815 oops: {
9816 SV* const tmpsv = sv_newmortal();
9817 gv_efullname3(tmpsv, namegv, NULL);
9818 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9819 SVfARG(tmpsv), SVfARG(protosv));
9820 }
d9088386
Z		 9821 }
9822
3ad73efd 9823 op_lvalue(aop, OP_ENTERSUB);
d9088386
Z		 9824 prev = aop;
9825 aop = aop->op_sibling;
9826 }
9827 if (aop == cvop && *proto == '_') {
9828 /* generate an access to $_ */
9829 aop = newDEFSVOP();
9830 aop->op_sibling = prev->op_sibling;
9831 prev->op_sibling = aop; /* instead of cvop */
9832 }
9833 if (!optional && proto_end > proto &&
9834 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
ce16c625 9835 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
d9088386
Z		 9836 return entersubop;
9837}
9838
9839/*
9840=for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9841
9842Performs the fixup of the arguments part of an C<entersub> op tree either
9843based on a subroutine prototype or using default list-context processing.
9844This is the standard treatment used on a subroutine call, not marked
9845with C<&>, where the callee can be identified at compile time.
9846
9847I<protosv> supplies the subroutine prototype to be applied to the call,
9848or indicates that there is no prototype. It may be a normal scalar,
9849in which case if it is defined then the string value will be used
9850as a prototype, and if it is undefined then there is no prototype.
9851Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9852that has been cast to C<SV*>), of which the prototype will be used if it
9853has one. The prototype (or lack thereof) supplied, in whichever form,
9854does not need to match the actual callee referenced by the op tree.
9855
9856If the argument ops disagree with the prototype, for example by having
9857an unacceptable number of arguments, a valid op tree is returned anyway.
9858The error is reflected in the parser state, normally resulting in a single
9859exception at the top level of parsing which covers all the compilation
9860errors that occurred. In the error message, the callee is referred to
9861by the name defined by the I<namegv> parameter.
9862
9863=cut
9864*/
9865
9866OP *
9867Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9868 GV *namegv, SV *protosv)
9869{
9870 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9871 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9872 return ck_entersub_args_proto(entersubop, namegv, protosv);
9873 else
9874 return ck_entersub_args_list(entersubop);
9875}
9876
4aaa4757
FC		 9877OP *
9878Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9879{
9880 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9881 OP *aop = cUNOPx(entersubop)->op_first;
9882
9883 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9884
9885 if (!opnum) {
14f0f125 9886 OP *cvop;
4aaa4757
FC		 9887 if (!aop->op_sibling)
9888 aop = cUNOPx(aop)->op_first;
4aaa4757
FC		 9889 aop = aop->op_sibling;
9890 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9891 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9892 aop = aop->op_sibling;
4aaa4757
FC		 9893 }
9894 if (aop != cvop)
ce16c625 9895 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
4aaa4757
FC		 9896
9897 op_free(entersubop);
9898 switch(GvNAME(namegv)[2]) {
9899 case 'F': return newSVOP(OP_CONST, 0,
9900 newSVpv(CopFILE(PL_curcop),0));
9901 case 'L': return newSVOP(
9902 OP_CONST, 0,
9903 Perl_newSVpvf(aTHX_
9904 "%"IVdf, (IV)CopLINE(PL_curcop)
9905 )
9906 );
9907 case 'P': return newSVOP(OP_CONST, 0,
9908 (PL_curstash
9909 ? newSVhek(HvNAME_HEK(PL_curstash))
9910 : &PL_sv_undef
9911 )
9912 );
9913 }
9914 assert(0);
9915 }
9916 else {
9917 OP *prev, *cvop;
7d789282 9918 U32 flags;
4aaa4757
FC		 9919#ifdef PERL_MAD
9920 bool seenarg = FALSE;
9921#endif
9922 if (!aop->op_sibling)
9923 aop = cUNOPx(aop)->op_first;
9924
9925 prev = aop;
9926 aop = aop->op_sibling;
9927 prev->op_sibling = NULL;
9928 for (cvop = aop;
9929 cvop->op_sibling;
9930 prev=cvop, cvop = cvop->op_sibling)
9931#ifdef PERL_MAD
9932 if (PL_madskills && cvop->op_sibling
9933 && cvop->op_type != OP_STUB) seenarg = TRUE
9934#endif
9935 ;
9936 prev->op_sibling = NULL;
7d789282 9937 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
4aaa4757
FC		 9938 op_free(cvop);
9939 if (aop == cvop) aop = NULL;
9940 op_free(entersubop);
9941
7d789282
FC		 9942 if (opnum == OP_ENTEREVAL
9943 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
9944 flags |= OPpEVAL_BYTES <<8;
9945
4aaa4757
FC		 9946 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9947 case OA_UNOP:
9948 case OA_BASEOP_OR_UNOP:
9949 case OA_FILESTATOP:
7d789282 9950 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
4aaa4757
FC		 9951 case OA_BASEOP:
9952 if (aop) {
9953#ifdef PERL_MAD
9954 if (!PL_madskills || seenarg)
9955#endif
ce16c625 9956 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
4aaa4757
FC		 9957 op_free(aop);
9958 }
98be9964
FC		 9959 return opnum == OP_RUNCV
9960 ? newPVOP(OP_RUNCV,0,NULL)
9961 : newOP(opnum,0);
4aaa4757
FC		 9962 default:
9963 return convert(opnum,0,aop);
9964 }
9965 }
9966 assert(0);
9967 return entersubop;
9968}
9969
d9088386
Z		 9970/*
9971=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9972
9973Retrieves the function that will be used to fix up a call to I<cv>.
9974Specifically, the function is applied to an C<entersub> op tree for a
9975subroutine call, not marked with C<&>, where the callee can be identified
9976at compile time as I<cv>.
9977
9978The C-level function pointer is returned in I<*ckfun_p>, and an SV
9979argument for it is returned in I<*ckobj_p>. The function is intended
9980to be called in this manner:
9981
9982 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9983
9984In this call, I<entersubop> is a pointer to the C<entersub> op,
9985which may be replaced by the check function, and I<namegv> is a GV
9986supplying the name that should be used by the check function to refer
9987to the callee of the C<entersub> op if it needs to emit any diagnostics.
9988It is permitted to apply the check function in non-standard situations,
9989such as to a call to a different subroutine or to a method call.
340458b5 9990
d9088386
Z		 9991By default, the function is
9992L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9993and the SV parameter is I<cv> itself. This implements standard
9994prototype processing. It can be changed, for a particular subroutine,
9995by L</cv_set_call_checker>.
74735042 9996
d9088386
Z		 9997=cut
9998*/
9999
10000void
10001Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10002{
10003 MAGIC *callmg;
10004 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10005 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10006 if (callmg) {
10007 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10008 *ckobj_p = callmg->mg_obj;
10009 } else {
10010 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10011 *ckobj_p = (SV*)cv;
10012 }
10013}
10014
10015/*
10016=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10017
10018Sets the function that will be used to fix up a call to I<cv>.
10019Specifically, the function is applied to an C<entersub> op tree for a
10020subroutine call, not marked with C<&>, where the callee can be identified
10021at compile time as I<cv>.
10022
10023The C-level function pointer is supplied in I<ckfun>, and an SV argument
10024for it is supplied in I<ckobj>. The function is intended to be called
10025in this manner:
10026
10027 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10028
10029In this call, I<entersubop> is a pointer to the C<entersub> op,
10030which may be replaced by the check function, and I<namegv> is a GV
10031supplying the name that should be used by the check function to refer
10032to the callee of the C<entersub> op if it needs to emit any diagnostics.
10033It is permitted to apply the check function in non-standard situations,
10034such as to a call to a different subroutine or to a method call.
10035
10036The current setting for a particular CV can be retrieved by
10037L</cv_get_call_checker>.
10038
10039=cut
10040*/
10041
10042void
10043Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10044{
10045 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10046 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10047 if (SvMAGICAL((SV*)cv))
10048 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10049 } else {
10050 MAGIC *callmg;
10051 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10052 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10053 if (callmg->mg_flags & MGf_REFCOUNTED) {
10054 SvREFCNT_dec(callmg->mg_obj);
10055 callmg->mg_flags &= ~MGf_REFCOUNTED;
10056 }
10057 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10058 callmg->mg_obj = ckobj;
10059 if (ckobj != (SV*)cv) {
10060 SvREFCNT_inc_simple_void_NN(ckobj);
10061 callmg->mg_flags |= MGf_REFCOUNTED;
74735042 10062 }
09fb282d 10063 callmg->mg_flags |= MGf_COPY;
340458b5 10064 }
d9088386
Z		 10065}
10066
10067OP *
10068Perl_ck_subr(pTHX_ OP *o)
10069{
10070 OP *aop, *cvop;
10071 CV *cv;
10072 GV *namegv;
10073
10074 PERL_ARGS_ASSERT_CK_SUBR;
10075
10076 aop = cUNOPx(o)->op_first;
10077 if (!aop->op_sibling)
10078 aop = cUNOPx(aop)->op_first;
10079 aop = aop->op_sibling;
10080 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10081 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10082 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10083
767eda44 10084 o->op_private &= ~1;
d9088386
Z		 10085 o->op_private |= OPpENTERSUB_HASTARG;
10086 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10087 if (PERLDB_SUB && PL_curstash != PL_debstash)
10088 o->op_private |= OPpENTERSUB_DB;
10089 if (cvop->op_type == OP_RV2CV) {
10090 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10091 op_null(cvop);
10092 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10093 if (aop->op_type == OP_CONST)
10094 aop->op_private &= ~OPpCONST_STRICT;
10095 else if (aop->op_type == OP_LIST) {
10096 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10097 if (sib && sib->op_type == OP_CONST)
10098 sib->op_private &= ~OPpCONST_STRICT;
10099 }
10100 }
10101
10102 if (!cv) {
10103 return ck_entersub_args_list(o);
10104 } else {
10105 Perl_call_checker ckfun;
10106 SV *ckobj;
10107 cv_get_call_checker(cv, &ckfun, &ckobj);
10108 return ckfun(aTHX_ o, namegv, ckobj);
10109 }
79072805
LW		 10110}
10111
10112OP *
cea2e8a9 10113Perl_ck_svconst(pTHX_ OP *o)
8990e307 10114{
7918f24d 10115 PERL_ARGS_ASSERT_CK_SVCONST;
96a5add6 10116 PERL_UNUSED_CONTEXT;
11343788
MB		 10117 SvREADONLY_on(cSVOPo->op_sv);
10118 return o;
8990e307
LW		 10119}
10120
10121OP *
d4ac975e
GA		 10122Perl_ck_chdir(pTHX_ OP *o)
10123{
a4e74480 10124 PERL_ARGS_ASSERT_CK_CHDIR;
d4ac975e 10125 if (o->op_flags & OPf_KIDS) {
1496a290 10126 SVOP * const kid = (SVOP*)cUNOPo->op_first;
d4ac975e
GA		 10127
10128 if (kid && kid->op_type == OP_CONST &&
10129 (kid->op_private & OPpCONST_BARE))
10130 {
10131 o->op_flags |= OPf_SPECIAL;
10132 kid->op_private &= ~OPpCONST_STRICT;
10133 }
10134 }
10135 return ck_fun(o);
10136}
10137
10138OP *
cea2e8a9 10139Perl_ck_trunc(pTHX_ OP *o)
79072805 10140{
7918f24d
NC		 10141 PERL_ARGS_ASSERT_CK_TRUNC;
10142
11343788
MB		 10143 if (o->op_flags & OPf_KIDS) {
10144 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 10145
a0d0e21e
LW		 10146 if (kid->op_type == OP_NULL)
10147 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 10148 if (kid && kid->op_type == OP_CONST &&
10149 (kid->op_private & OPpCONST_BARE))
10150 {
11343788 10151 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 10152 kid->op_private &= ~OPpCONST_STRICT;
10153 }
79072805 10154 }
11343788 10155 return ck_fun(o);
79072805
LW		 10156}
10157
35fba0d9
RG		 10158OP *
10159Perl_ck_substr(pTHX_ OP *o)
10160{
7918f24d
NC		 10161 PERL_ARGS_ASSERT_CK_SUBSTR;
10162
35fba0d9 10163 o = ck_fun(o);
1d866c12 10164 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 10165 OP *kid = cLISTOPo->op_first;
10166
10167 if (kid->op_type == OP_NULL)
10168 kid = kid->op_sibling;
10169 if (kid)
10170 kid->op_flags |= OPf_MOD;
10171
10172 }
10173 return o;
10174}
10175
878d132a 10176OP *
8dc99089
FC		 10177Perl_ck_tell(pTHX_ OP *o)
10178{
8dc99089
FC		 10179 PERL_ARGS_ASSERT_CK_TELL;
10180 o = ck_fun(o);
e9d7a483
FC		 10181 if (o->op_flags & OPf_KIDS) {
10182 OP *kid = cLISTOPo->op_first;
423e8af5 10183 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
e9d7a483
FC		 10184 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10185 }
8dc99089
FC		 10186 return o;
10187}
10188
10189OP *
cba5a3b0
DG		 10190Perl_ck_each(pTHX_ OP *o)
10191{
10192 dVAR;
10193 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10194 const unsigned orig_type = o->op_type;
10195 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10196 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10197 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10198 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10199
10200 PERL_ARGS_ASSERT_CK_EACH;
10201
10202 if (kid) {
10203 switch (kid->op_type) {
10204 case OP_PADHV:
10205 case OP_RV2HV:
10206 break;
10207 case OP_PADAV:
10208 case OP_RV2AV:
10209 CHANGE_TYPE(o, array_type);
10210 break;
10211 case OP_CONST:
7ac5715b
FC		 10212 if (kid->op_private == OPpCONST_BARE
10213 || !SvROK(cSVOPx_sv(kid))
10214 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10215 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10216 )
10217 /* we let ck_fun handle it */
cba5a3b0
DG		 10218 break;
10219 default:
10220 CHANGE_TYPE(o, ref_type);
7ac5715b 10221 scalar(kid);
cba5a3b0
DG		 10222 }
10223 }
10224 /* if treating as a reference, defer additional checks to runtime */
10225 return o->op_type == ref_type ? o : ck_fun(o);
10226}
10227
e508c8a4
MH		 10228OP *
10229Perl_ck_length(pTHX_ OP *o)
10230{
10231 PERL_ARGS_ASSERT_CK_LENGTH;
10232
10233 o = ck_fun(o);
10234
10235 if (ckWARN(WARN_SYNTAX)) {
10236 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10237
10238 if (kid) {
579333ee
FC		 10239 SV *name = NULL;
10240 const bool hash = kid->op_type == OP_PADHV
10241 || kid->op_type == OP_RV2HV;
e508c8a4
MH		 10242 switch (kid->op_type) {
10243 case OP_PADHV:
e508c8a4 10244 case OP_PADAV:
579333ee 10245 name = varname(
c6fb3f6e
FC		 10246 (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
10247 NULL, 0, 1
579333ee
FC		 10248 );
10249 break;
10250 case OP_RV2HV:
e508c8a4 10251 case OP_RV2AV:
579333ee
FC		 10252 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
10253 {
10254 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
10255 if (!gv) break;
10256 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
10257 }
e508c8a4 10258 break;
e508c8a4 10259 default:
579333ee 10260 return o;
e508c8a4 10261 }
579333ee
FC		 10262 if (name)
10263 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10264 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10265 ")\"?)",
10266 name, hash ? "keys " : "", name
10267 );
10268 else if (hash)
10269 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10270 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10271 else
10272 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10273 "length() used on @array (did you mean \"scalar(@array)\"?)");
e508c8a4
MH		 10274 }
10275 }
10276
10277 return o;
10278}
10279
867fa1e2
YO		 10280/* caller is supposed to assign the return to the
10281 container of the rep_op var */
20381b50 10282STATIC OP *
867fa1e2 10283S_opt_scalarhv(pTHX_ OP *rep_op) {
749123ff 10284 dVAR;
867fa1e2
YO		 10285 UNOP *unop;
10286
10287 PERL_ARGS_ASSERT_OPT_SCALARHV;
10288
10289 NewOp(1101, unop, 1, UNOP);
10290 unop->op_type = (OPCODE)OP_BOOLKEYS;
10291 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
10292 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
10293 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
10294 unop->op_first = rep_op;
10295 unop->op_next = rep_op->op_next;
10296 rep_op->op_next = (OP*)unop;
10297 rep_op->op_flags|=(OPf_REF | OPf_MOD);
10298 unop->op_sibling = rep_op->op_sibling;
10299 rep_op->op_sibling = NULL;
10300 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
10301 if (rep_op->op_type == OP_PADHV) {
10302 rep_op->op_flags &= ~OPf_WANT_SCALAR;
10303 rep_op->op_flags |= OPf_WANT_LIST;
10304 }
10305 return (OP*)unop;
10306}
10307
540dd770
GG		 10308/* Check for in place reverse and sort assignments like "@a = reverse @a"
10309 and modify the optree to make them work inplace */
e52d58aa 10310
540dd770
GG		 10311STATIC void
10312S_inplace_aassign(pTHX_ OP *o) {
e52d58aa 10313
540dd770
GG		 10314 OP *modop, *modop_pushmark;
10315 OP *oright;
10316 OP *oleft, *oleft_pushmark;
e52d58aa 10317
540dd770 10318 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
e52d58aa 10319
540dd770 10320 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
e52d58aa 10321
540dd770
GG		 10322 assert(cUNOPo->op_first->op_type == OP_NULL);
10323 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10324 assert(modop_pushmark->op_type == OP_PUSHMARK);
10325 modop = modop_pushmark->op_sibling;
e92f843d 10326
540dd770
GG		 10327 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10328 return;
10329
10330 /* no other operation except sort/reverse */
10331 if (modop->op_sibling)
10332 return;
10333
10334 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
a46b39a8 10335 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
540dd770
GG		 10336
10337 if (modop->op_flags & OPf_STACKED) {
10338 /* skip sort subroutine/block */
10339 assert(oright->op_type == OP_NULL);
10340 oright = oright->op_sibling;
10341 }
10342
10343 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10344 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10345 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10346 oleft = oleft_pushmark->op_sibling;
10347
10348 /* Check the lhs is an array */
10349 if (!oleft ||
10350 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10351 || oleft->op_sibling
10352 || (oleft->op_private & OPpLVAL_INTRO)
10353 )
10354 return;
10355
10356 /* Only one thing on the rhs */
10357 if (oright->op_sibling)
10358 return;
2f9e2db0
VP		 10359
10360 /* check the array is the same on both sides */
10361 if (oleft->op_type == OP_RV2AV) {
10362 if (oright->op_type != OP_RV2AV
10363 || !cUNOPx(oright)->op_first
10364 || cUNOPx(oright)->op_first->op_type != OP_GV
18e3e9ce 10365 || cUNOPx(oleft )->op_first->op_type != OP_GV
2f9e2db0
VP		 10366 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10367 cGVOPx_gv(cUNOPx(oright)->op_first)
10368 )
540dd770 10369 return;
2f9e2db0
VP		 10370 }
10371 else if (oright->op_type != OP_PADAV
10372 || oright->op_targ != oleft->op_targ
10373 )
540dd770
GG		 10374 return;
10375
10376 /* This actually is an inplace assignment */
e52d58aa 10377
540dd770
GG		 10378 modop->op_private |= OPpSORT_INPLACE;
10379
10380 /* transfer MODishness etc from LHS arg to RHS arg */
10381 oright->op_flags = oleft->op_flags;
10382
10383 /* remove the aassign op and the lhs */
10384 op_null(o);
10385 op_null(oleft_pushmark);
10386 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10387 op_null(cUNOPx(oleft)->op_first);
10388 op_null(oleft);
2f9e2db0
VP		 10389}
10390
3c78429c
DM		 10391#define MAX_DEFERRED 4
10392
10393#define DEFER(o) \
10394 if (defer_ix == (MAX_DEFERRED-1)) { \
10395 CALL_RPEEP(defer_queue[defer_base]); \
10396 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10397 defer_ix--; \
10398 } \
10399 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
10400
61b743bb
DM		 10401/* A peephole optimizer. We visit the ops in the order they're to execute.
10402 * See the comments at the top of this file for more details about when
10403 * peep() is called */
463ee0b2 10404
79072805 10405void
1a0a2ba9 10406Perl_rpeep(pTHX_ register OP *o)
79072805 10407{
27da23d5 10408 dVAR;
c445ea15 10409 register OP* oldop = NULL;
3c78429c
DM		 10410 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10411 int defer_base = 0;
10412 int defer_ix = -1;
2d8e6c8d 10413
2814eb74 10414 if (!o || o->op_opt)
79072805 10415 return;
a0d0e21e 10416 ENTER;
462e5cf6 10417 SAVEOP();
7766f137 10418 SAVEVPTR(PL_curcop);
3c78429c
DM		 10419 for (;; o = o->op_next) {
10420 if (o && o->op_opt)
10421 o = NULL;
cd197e1e
VP		 10422 if (!o) {
10423 while (defer_ix >= 0)
10424 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
3c78429c 10425 break;
cd197e1e 10426 }
3c78429c 10427
6d7dd4a5
NC		 10428 /* By default, this op has now been optimised. A couple of cases below
10429 clear this again. */
10430 o->op_opt = 1;
533c011a 10431 PL_op = o;
a0d0e21e 10432 switch (o->op_type) {
a0d0e21e 10433 case OP_DBSTATE:
3280af22 10434 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e 10435 break;
ac56e7de
NC		 10436 case OP_NEXTSTATE:
10437 PL_curcop = ((COP*)o); /* for warnings */
10438
10439 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10440 to carry two labels. For now, take the easier option, and skip
10441 this optimisation if the first NEXTSTATE has a label. */
bcc76ee3 10442 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
ac56e7de
NC		 10443 OP *nextop = o->op_next;
10444 while (nextop && nextop->op_type == OP_NULL)
10445 nextop = nextop->op_next;
10446
10447 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10448 COP *firstcop = (COP *)o;
10449 COP *secondcop = (COP *)nextop;
10450 /* We want the COP pointed to by o (and anything else) to
10451 become the next COP down the line. */
10452 cop_free(firstcop);
10453
10454 firstcop->op_next = secondcop->op_next;
10455
10456 /* Now steal all its pointers, and duplicate the other
10457 data. */
10458 firstcop->cop_line = secondcop->cop_line;
10459#ifdef USE_ITHREADS
d4d03940 10460 firstcop->cop_stashoff = secondcop->cop_stashoff;
ac56e7de
NC		 10461 firstcop->cop_file = secondcop->cop_file;
10462#else
10463 firstcop->cop_stash = secondcop->cop_stash;
10464 firstcop->cop_filegv = secondcop->cop_filegv;
10465#endif
10466 firstcop->cop_hints = secondcop->cop_hints;
10467 firstcop->cop_seq = secondcop->cop_seq;
10468 firstcop->cop_warnings = secondcop->cop_warnings;
10469 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10470
10471#ifdef USE_ITHREADS
647688d8 10472 secondcop->cop_stashoff = 0;
ac56e7de
NC		 10473 secondcop->cop_file = NULL;
10474#else
10475 secondcop->cop_stash = NULL;
10476 secondcop->cop_filegv = NULL;
10477#endif
10478 secondcop->cop_warnings = NULL;
10479 secondcop->cop_hints_hash = NULL;
10480
10481 /* If we use op_null(), and hence leave an ex-COP, some
10482 warnings are misreported. For example, the compile-time
10483 error in 'use strict; no strict refs;' */
10484 secondcop->op_type = OP_NULL;
10485 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10486 }
10487 }
10488 break;
a0d0e21e 10489
df91b2c5
AE		 10490 case OP_CONCAT:
10491 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10492 if (o->op_next->op_private & OPpTARGET_MY) {
10493 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 10494 break; /* ignore_optimization */
df91b2c5
AE		 10495 else {
10496 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10497 o->op_targ = o->op_next->op_targ;
10498 o->op_next->op_targ = 0;
10499 o->op_private |= OPpTARGET_MY;
10500 }
10501 }
10502 op_null(o->op_next);
10503 }
df91b2c5 10504 break;
6d7dd4a5
NC		 10505 case OP_STUB:
10506 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10507 break; /* Scalar stub must produce undef. List stub is noop */
10508 }
10509 goto nothin;
79072805 10510 case OP_NULL:
acb36ea4 10511 if (o->op_targ == OP_NEXTSTATE
5edb5b2a 10512 || o->op_targ == OP_DBSTATE)
acb36ea4 10513 {
3280af22 10514 PL_curcop = ((COP*)o);
acb36ea4 10515 }
dad75012 10516 /* XXX: We avoid setting op_seq here to prevent later calls
1a0a2ba9 10517 to rpeep() from mistakenly concluding that optimisation
dad75012
AMS		 10518 has already occurred. This doesn't fix the real problem,
10519 though (See 20010220.007). AMS 20010719 */
2814eb74 10520 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 10521 o->op_opt = 0;
f46f2f82 10522 /* FALL THROUGH */
79072805 10523 case OP_SCALAR:
93a17b20 10524 case OP_LINESEQ:
463ee0b2 10525 case OP_SCOPE:
6d7dd4a5 10526 nothin:
a0d0e21e
LW		 10527 if (oldop && o->op_next) {
10528 oldop->op_next = o->op_next;
6d7dd4a5 10529 o->op_opt = 0;
79072805
LW		 10530 continue;
10531 }
79072805
LW		 10532 break;
10533
6a077020 10534 case OP_PADAV:
79072805 10535 case OP_GV:
6a077020 10536 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 10537 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 10538 o->op_next : o->op_next->op_next;
a0d0e21e 10539 IV i;
f9dc862f 10540 if (pop && pop->op_type == OP_CONST &&
af5acbb4 10541 ((PL_op = pop->op_next)) &&
8990e307 10542 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 10543 !(pop->op_next->op_private &
78f9721b 10544 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
e1dccc0d 10545 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
8990e307 10546 {
350de78d 10547 GV *gv;
af5acbb4
DM		 10548 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
10549 no_bareword_allowed(pop);
6a077020
DM		 10550 if (o->op_type == OP_GV)
10551 op_null(o->op_next);
93c66552
DM		 10552 op_null(pop->op_next);
10553 op_null(pop);
a0d0e21e
LW		 10554 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
10555 o->op_next = pop->op_next->op_next;
22c35a8c 10556 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 10557 o->op_private = (U8)i;
6a077020
DM		 10558 if (o->op_type == OP_GV) {
10559 gv = cGVOPo_gv;
10560 GvAVn(gv);
93bad3fd 10561 o->op_type = OP_AELEMFAST;
6a077020
DM		 10562 }
10563 else
93bad3fd 10564 o->op_type = OP_AELEMFAST_LEX;
6a077020 10565 }
6a077020
DM		 10566 break;
10567 }
10568
10569 if (o->op_next->op_type == OP_RV2SV) {
10570 if (!(o->op_next->op_private & OPpDEREF)) {
10571 op_null(o->op_next);
10572 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
10573 | OPpOUR_INTRO);
10574 o->op_next = o->op_next->op_next;
10575 o->op_type = OP_GVSV;
10576 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 10577 }
79072805 10578 }
89de2904
AMS		 10579 else if (o->op_next->op_type == OP_READLINE
10580 && o->op_next->op_next->op_type == OP_CONCAT
10581 && (o->op_next->op_next->op_flags & OPf_STACKED))
10582 {
d2c45030
AMS		 10583 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
10584 o->op_type = OP_RCATLINE;
10585 o->op_flags |= OPf_STACKED;
10586 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 10587 op_null(o->op_next->op_next);
d2c45030 10588 op_null(o->op_next);
89de2904 10589 }
76cd736e 10590
79072805 10591 break;
867fa1e2
YO		 10592
10593 {
10594 OP *fop;
10595 OP *sop;
10596
10597 case OP_NOT:
10598 fop = cUNOP->op_first;
10599 sop = NULL;
10600 goto stitch_keys;
10601 break;
10602
10603 case OP_AND:
79072805 10604 case OP_OR:
c963b151 10605 case OP_DOR:
867fa1e2
YO		 10606 fop = cLOGOP->op_first;
10607 sop = fop->op_sibling;
10608 while (cLOGOP->op_other->op_type == OP_NULL)
10609 cLOGOP->op_other = cLOGOP->op_other->op_next;
db4d68cf
DM		 10610 while (o->op_next && ( o->op_type == o->op_next->op_type
10611 || o->op_next->op_type == OP_NULL))
10612 o->op_next = o->op_next->op_next;
3c78429c 10613 DEFER(cLOGOP->op_other);
867fa1e2
YO		 10614
10615 stitch_keys:
10616 o->op_opt = 1;
10617 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10618 || ( sop &&
10619 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
10620 )
10621 ){
10622 OP * nop = o;
10623 OP * lop = o;
aaf643ce 10624 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
867fa1e2
YO		 10625 while (nop && nop->op_next) {
10626 switch (nop->op_next->op_type) {
10627 case OP_NOT:
10628 case OP_AND:
10629 case OP_OR:
10630 case OP_DOR:
10631 lop = nop = nop->op_next;
10632 break;
10633 case OP_NULL:
10634 nop = nop->op_next;
10635 break;
10636 default:
10637 nop = NULL;
10638 break;
10639 }
10640 }
10641 }
aaf643ce 10642 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
867fa1e2
YO		 10643 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10644 cLOGOP->op_first = opt_scalarhv(fop);
10645 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
10646 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
10647 }
10648 }
10649
10650
10651 break;
10652 }
10653
10654 case OP_MAPWHILE:
10655 case OP_GREPWHILE:
2c2d71f5
JH		 10656 case OP_ANDASSIGN:
10657 case OP_ORASSIGN:
c963b151 10658 case OP_DORASSIGN:
1a67a97c
SM		 10659 case OP_COND_EXPR:
10660 case OP_RANGE:
c5917253 10661 case OP_ONCE:
fd4d1407
IZ		 10662 while (cLOGOP->op_other->op_type == OP_NULL)
10663 cLOGOP->op_other = cLOGOP->op_other->op_next;
3c78429c 10664 DEFER(cLOGOP->op_other);
79072805
LW		 10665 break;
10666
79072805 10667 case OP_ENTERLOOP:
9c2ca71a 10668 case OP_ENTERITER:
58cccf98
SM		 10669 while (cLOOP->op_redoop->op_type == OP_NULL)
10670 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
58cccf98
SM		 10671 while (cLOOP->op_nextop->op_type == OP_NULL)
10672 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
58cccf98
SM		 10673 while (cLOOP->op_lastop->op_type == OP_NULL)
10674 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
3c78429c
DM		 10675 /* a while(1) loop doesn't have an op_next that escapes the
10676 * loop, so we have to explicitly follow the op_lastop to
10677 * process the rest of the code */
10678 DEFER(cLOOP->op_lastop);
79072805
LW		 10679 break;
10680
79072805 10681 case OP_SUBST:
29f2e912
NC		 10682 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10683 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10684 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10685 cPMOP->op_pmstashstartu.op_pmreplstart
10686 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
3c78429c 10687 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 10688 break;
10689
fe1bc4cf 10690 case OP_SORT: {
fe1bc4cf 10691 /* check that RHS of sort is a single plain array */
551405c4 10692 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 10693 if (!oright || oright->op_type != OP_PUSHMARK)
10694 break;
471178c0 10695
540dd770
GG		 10696 if (o->op_private & OPpSORT_INPLACE)
10697 break;
10698
471178c0
NC		 10699 /* reverse sort ... can be optimised. */
10700 if (!cUNOPo->op_sibling) {
10701 /* Nothing follows us on the list. */
551405c4 10702 OP * const reverse = o->op_next;
471178c0
NC		 10703
10704 if (reverse->op_type == OP_REVERSE &&
10705 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 10706 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 10707 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10708 && (cUNOPx(pushmark)->op_sibling == o)) {
10709 /* reverse -> pushmark -> sort */
10710 o->op_private |= OPpSORT_REVERSE;
10711 op_null(reverse);
10712 pushmark->op_next = oright->op_next;
10713 op_null(oright);
10714 }
10715 }
10716 }
10717
fe1bc4cf
DM		 10718 break;
10719 }
ef3e5ea9
NC		 10720
10721 case OP_REVERSE: {
e682d7b7 10722 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 10723 OP *gvop = NULL;
ef3e5ea9 10724 LISTOP *enter, *exlist;
ef3e5ea9 10725
540dd770 10726 if (o->op_private & OPpSORT_INPLACE)
484c818f 10727 break;
484c818f 10728
ef3e5ea9
NC		 10729 enter = (LISTOP *) o->op_next;
10730 if (!enter)
10731 break;
10732 if (enter->op_type == OP_NULL) {
10733 enter = (LISTOP *) enter->op_next;
10734 if (!enter)
10735 break;
10736 }
d46f46af
NC		 10737 /* for $a (...) will have OP_GV then OP_RV2GV here.
10738 for (...) just has an OP_GV. */
ce335f37
NC		 10739 if (enter->op_type == OP_GV) {
10740 gvop = (OP *) enter;
10741 enter = (LISTOP *) enter->op_next;
10742 if (!enter)
10743 break;
d46f46af
NC		 10744 if (enter->op_type == OP_RV2GV) {
10745 enter = (LISTOP *) enter->op_next;
10746 if (!enter)
ce335f37 10747 break;
d46f46af 10748 }
ce335f37
NC		 10749 }
10750
ef3e5ea9
NC		 10751 if (enter->op_type != OP_ENTERITER)
10752 break;
10753
10754 iter = enter->op_next;
10755 if (!iter || iter->op_type != OP_ITER)
10756 break;
10757
ce335f37
NC		 10758 expushmark = enter->op_first;
10759 if (!expushmark || expushmark->op_type != OP_NULL
10760 || expushmark->op_targ != OP_PUSHMARK)
10761 break;
10762
10763 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 10764 if (!exlist || exlist->op_type != OP_NULL
10765 || exlist->op_targ != OP_LIST)
10766 break;
10767
10768 if (exlist->op_last != o) {
10769 /* Mmm. Was expecting to point back to this op. */
10770 break;
10771 }
10772 theirmark = exlist->op_first;
10773 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10774 break;
10775
c491ecac 10776 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 10777 /* There's something between the mark and the reverse, eg
10778 for (1, reverse (...))
10779 so no go. */
10780 break;
10781 }
10782
c491ecac
NC		 10783 ourmark = ((LISTOP *)o)->op_first;
10784 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10785 break;
10786
ef3e5ea9
NC		 10787 ourlast = ((LISTOP *)o)->op_last;
10788 if (!ourlast || ourlast->op_next != o)
10789 break;
10790
e682d7b7
NC		 10791 rv2av = ourmark->op_sibling;
10792 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10793 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10794 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10795 /* We're just reversing a single array. */
10796 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10797 enter->op_flags |= OPf_STACKED;
10798 }
10799
ef3e5ea9
NC		 10800 /* We don't have control over who points to theirmark, so sacrifice
10801 ours. */
10802 theirmark->op_next = ourmark->op_next;
10803 theirmark->op_flags = ourmark->op_flags;
ce335f37 10804 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 10805 op_null(ourmark);
10806 op_null(o);
10807 enter->op_private |= OPpITER_REVERSED;
10808 iter->op_private |= OPpITER_REVERSED;
10809
10810 break;
10811 }
e26df76a 10812
0477511c
NC		 10813 case OP_QR:
10814 case OP_MATCH:
29f2e912
NC		 10815 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10816 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10817 }
79072805 10818 break;
1830b3d9 10819
1a35f9ff
FC		 10820 case OP_RUNCV:
10821 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
10822 SV *sv;
e157a82b 10823 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
1a35f9ff
FC		 10824 else {
10825 sv = newRV((SV *)PL_compcv);
10826 sv_rvweaken(sv);
10827 SvREADONLY_on(sv);
10828 }
10829 o->op_type = OP_CONST;
10830 o->op_ppaddr = PL_ppaddr[OP_CONST];
10831 o->op_flags |= OPf_SPECIAL;
10832 cSVOPo->op_sv = sv;
10833 }
10834 break;
10835
24fcb59f
FC		 10836 case OP_SASSIGN:
10837 if (OP_GIMME(o,0) == G_VOID) {
10838 OP *right = cBINOP->op_first;
10839 if (right) {
10840 OP *left = right->op_sibling;
10841 if (left->op_type == OP_SUBSTR
10842 && (left->op_private & 7) < 4) {
10843 op_null(o);
10844 cBINOP->op_first = left;
10845 right->op_sibling =
10846 cBINOPx(left)->op_first->op_sibling;
10847 cBINOPx(left)->op_first->op_sibling = right;
10848 left->op_private |= OPpSUBSTR_REPL_FIRST;
d72a08ce
FC		 10849 left->op_flags =
10850 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
24fcb59f
FC		 10851 }
10852 }
10853 }
10854 break;
10855
1830b3d9
BM		 10856 case OP_CUSTOM: {
10857 Perl_cpeep_t cpeep =
10858 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10859 if (cpeep)
10860 cpeep(aTHX_ o, oldop);
10861 break;
10862 }
10863
79072805 10864 }
a0d0e21e 10865 oldop = o;
79072805 10866 }
a0d0e21e 10867 LEAVE;
79072805 10868}
beab0874 10869
1a0a2ba9
Z		 10870void
10871Perl_peep(pTHX_ register OP *o)
10872{
10873 CALL_RPEEP(o);
10874}
10875
9733086d
BM		 10876/*
10877=head1 Custom Operators
10878
10879=for apidoc Ao||custom_op_xop
10880Return the XOP structure for a given custom op. This function should be
10881considered internal to OP_NAME and the other access macros: use them instead.
10882
10883=cut
10884*/
10885
1830b3d9
BM		 10886const XOP *
10887Perl_custom_op_xop(pTHX_ const OP *o)
53e06cf0 10888{
1830b3d9
BM		 10889 SV *keysv;
10890 HE *he = NULL;
10891 XOP *xop;
10892
10893 static const XOP xop_null = { 0, 0, 0, 0, 0 };
53e06cf0 10894
1830b3d9
BM		 10895 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10896 assert(o->op_type == OP_CUSTOM);
7918f24d 10897
1830b3d9
BM		 10898 /* This is wrong. It assumes a function pointer can be cast to IV,
10899 * which isn't guaranteed, but this is what the old custom OP code
10900 * did. In principle it should be safer to Copy the bytes of the
10901 * pointer into a PV: since the new interface is hidden behind
10902 * functions, this can be changed later if necessary. */
10903 /* Change custom_op_xop if this ever happens */
10904 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
53e06cf0 10905
1830b3d9
BM		 10906 if (PL_custom_ops)
10907 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10908
10909 /* assume noone will have just registered a desc */
10910 if (!he && PL_custom_op_names &&
10911 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10912 ) {
10913 const char *pv;
10914 STRLEN l;
10915
10916 /* XXX does all this need to be shared mem? */
aca83993 10917 Newxz(xop, 1, XOP);
1830b3d9
BM		 10918 pv = SvPV(HeVAL(he), l);
10919 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10920 if (PL_custom_op_descs &&
10921 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10922 ) {
10923 pv = SvPV(HeVAL(he), l);
10924 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10925 }
10926 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10927 return xop;
10928 }
53e06cf0 10929
1830b3d9 10930 if (!he) return &xop_null;
53e06cf0 10931
1830b3d9
BM		 10932 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10933 return xop;
53e06cf0
SC		 10934}
10935
9733086d
BM		 10936/*
10937=for apidoc Ao||custom_op_register
10938Register a custom op. See L<perlguts/"Custom Operators">.
53e06cf0 10939
9733086d
BM		 10940=cut
10941*/
7918f24d 10942
1830b3d9
BM		 10943void
10944Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10945{
10946 SV *keysv;
10947
10948 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
53e06cf0 10949
1830b3d9
BM		 10950 /* see the comment in custom_op_xop */
10951 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
53e06cf0 10952
1830b3d9
BM		 10953 if (!PL_custom_ops)
10954 PL_custom_ops = newHV();
53e06cf0 10955
1830b3d9
BM		 10956 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10957 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
53e06cf0 10958}
19e8ce8e 10959
b8c38f0a
FC		 10960/*
10961=head1 Functions in file op.c
10962
10963=for apidoc core_prototype
10964This function assigns the prototype of the named core function to C<sv>, or
10965to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
a051f6c4 10966NULL if the core function has no prototype. C<code> is a code as returned
4e338c21 10967by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
b8c38f0a
FC		 10968
10969=cut
10970*/
10971
10972SV *
be1b855b 10973Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
b66130dd 10974 int * const opnum)
b8c38f0a 10975{
b8c38f0a
FC		 10976 int i = 0, n = 0, seen_question = 0, defgv = 0;
10977 I32 oa;
10978#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10979 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
9927957a 10980 bool nullret = FALSE;
b8c38f0a
FC		 10981
10982 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10983
4e338c21 10984 assert (code && code != -KEY_CORE);
b8c38f0a
FC		 10985
10986 if (!sv) sv = sv_newmortal();
10987
9927957a 10988#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
b8c38f0a 10989
4e338c21 10990 switch (code < 0 ? -code : code) {
b8c38f0a 10991 case KEY_and : case KEY_chop: case KEY_chomp:
4e338c21
FC		 10992 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
10993 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
10994 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
10995 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
10996 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
10997 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
10998 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
10999 case KEY_x : case KEY_xor :
9927957a 11000 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
4e338c21 11001 case KEY_glob: retsetpvs("_;", OP_GLOB);
9927957a
FC		 11002 case KEY_keys: retsetpvs("+", OP_KEYS);
11003 case KEY_values: retsetpvs("+", OP_VALUES);
11004 case KEY_each: retsetpvs("+", OP_EACH);
11005 case KEY_push: retsetpvs("+@", OP_PUSH);
11006 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11007 case KEY_pop: retsetpvs(";+", OP_POP);
11008 case KEY_shift: retsetpvs(";+", OP_SHIFT);
4e338c21 11009 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
b8c38f0a 11010 case KEY_splice:
9927957a 11011 retsetpvs("+;$$@", OP_SPLICE);
b8c38f0a 11012 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
9927957a 11013 retsetpvs("", 0);
7d789282
FC		 11014 case KEY_evalbytes:
11015 name = "entereval"; break;
b8c38f0a
FC		 11016 case KEY_readpipe:
11017 name = "backtick";
11018 }
11019
11020#undef retsetpvs
11021
9927957a 11022 findopnum:
b8c38f0a
FC		 11023 while (i < MAXO) { /* The slow way. */
11024 if (strEQ(name, PL_op_name[i])
11025 || strEQ(name, PL_op_desc[i]))
11026 {
9927957a 11027 if (nullret) { assert(opnum); *opnum = i; return NULL; }
b8c38f0a
FC		 11028 goto found;
11029 }
11030 i++;
11031 }
4e338c21 11032 return NULL;
b8c38f0a
FC		 11033 found:
11034 defgv = PL_opargs[i] & OA_DEFGV;
11035 oa = PL_opargs[i] >> OASHIFT;
11036 while (oa) {
465bc0f5 11037 if (oa & OA_OPTIONAL && !seen_question && (
ea5703f4 11038 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
465bc0f5 11039 )) {
b8c38f0a
FC		 11040 seen_question = 1;
11041 str[n++] = ';';
11042 }
11043 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
11044 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
11045 /* But globs are already references (kinda) */
11046 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
11047 ) {
11048 str[n++] = '\\';
11049 }
1ecbeecf
FC		 11050 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
11051 && !scalar_mod_type(NULL, i)) {
11052 str[n++] = '[';
11053 str[n++] = '$';
11054 str[n++] = '@';
11055 str[n++] = '%';
89c5c07e 11056 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
1ecbeecf
FC		 11057 str[n++] = '*';
11058 str[n++] = ']';
11059 }
11060 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
ea5703f4
FC		 11061 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
11062 str[n-1] = '_'; defgv = 0;
11063 }
b8c38f0a
FC		 11064 oa = oa >> 4;
11065 }
dcbdef25 11066 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
b8c38f0a
FC		 11067 str[n++] = '\0';
11068 sv_setpvn(sv, str, n - 1);
9927957a 11069 if (opnum) *opnum = i;
b8c38f0a
FC		 11070 return sv;
11071}
11072
1e4b6aa1
FC		 11073OP *
11074Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11075 const int opnum)
11076{
11077 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
c931b036 11078 OP *o;
1e4b6aa1
FC		 11079
11080 PERL_ARGS_ASSERT_CORESUB_OP;
11081
11082 switch(opnum) {
11083 case 0:
c2f605db 11084 return op_append_elem(OP_LINESEQ,
1e4b6aa1
FC		 11085 argop,
11086 newSLICEOP(0,
c2f605db 11087 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
1e4b6aa1
FC		 11088 newOP(OP_CALLER,0)
11089 )
c2f605db 11090 );
720d5b2f
FC		 11091 case OP_SELECT: /* which represents OP_SSELECT as well */
11092 if (code)
11093 return newCONDOP(
11094 0,
11095 newBINOP(OP_GT, 0,
11096 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11097 newSVOP(OP_CONST, 0, newSVuv(1))
11098 ),
11099 coresub_op(newSVuv((UV)OP_SSELECT), 0,
11100 OP_SSELECT),
11101 coresub_op(coreargssv, 0, OP_SELECT)
11102 );
11103 /* FALL THROUGH */
1e4b6aa1
FC		 11104 default:
11105 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11106 case OA_BASEOP:
11107 return op_append_elem(
11108 OP_LINESEQ, argop,
11109 newOP(opnum,
84ed0108
FC		 11110 opnum == OP_WANTARRAY || opnum == OP_RUNCV
11111 ? OPpOFFBYONE << 8 : 0)
1e4b6aa1 11112 );
527d644b 11113 case OA_BASEOP_OR_UNOP:
7d789282
FC		 11114 if (opnum == OP_ENTEREVAL) {
11115 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11116 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11117 }
11118 else o = newUNOP(opnum,0,argop);
ce0b554b
FC		 11119 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11120 else {
c931b036 11121 onearg:
ce0b554b 11122 if (is_handle_constructor(o, 1))
c931b036 11123 argop->op_private |= OPpCOREARGS_DEREF1;
1efec5ed
FC		 11124 if (scalar_mod_type(NULL, opnum))
11125 argop->op_private |= OPpCOREARGS_SCALARMOD;
ce0b554b 11126 }
c931b036 11127 return o;
527d644b 11128 default:
498a02d8 11129 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
c931b036
FC		 11130 if (is_handle_constructor(o, 2))
11131 argop->op_private |= OPpCOREARGS_DEREF2;
7bc95ae1
FC		 11132 if (opnum == OP_SUBSTR) {
11133 o->op_private |= OPpMAYBE_LVSUB;
11134 return o;
11135 }
11136 else goto onearg;
1e4b6aa1
FC		 11137 }
11138 }
11139}
11140
156d738f
FC		 11141void
11142Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11143 SV * const *new_const_svp)
11144{
11145 const char *hvname;
11146 bool is_const = !!CvCONST(old_cv);
11147 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11148
11149 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11150
11151 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11152 return;
11153 /* They are 2 constant subroutines generated from
11154 the same constant. This probably means that
11155 they are really the "same" proxy subroutine
11156 instantiated in 2 places. Most likely this is
11157 when a constant is exported twice. Don't warn.
11158 */
11159 if (
11160 (ckWARN(WARN_REDEFINE)
11161 && !(
11162 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11163 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11164 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11165 strEQ(hvname, "autouse"))
11166 )
11167 )
11168 || (is_const
11169 && ckWARN_d(WARN_REDEFINE)
11170 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11171 )
11172 )
11173 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11174 is_const
11175 ? "Constant subroutine %"SVf" redefined"
11176 : "Subroutine %"SVf" redefined",
11177 name);
11178}
11179
e8570548
Z		 11180/*
11181=head1 Hook manipulation
11182
11183These functions provide convenient and thread-safe means of manipulating
11184hook variables.
11185
11186=cut
11187*/
11188
11189/*
11190=for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
11191
11192Puts a C function into the chain of check functions for a specified op
11193type. This is the preferred way to manipulate the L</PL_check> array.
11194I<opcode> specifies which type of op is to be affected. I<new_checker>
11195is a pointer to the C function that is to be added to that opcode's
11196check chain, and I<old_checker_p> points to the storage location where a
11197pointer to the next function in the chain will be stored. The value of
11198I<new_pointer> is written into the L</PL_check> array, while the value
11199previously stored there is written to I<*old_checker_p>.
11200
11201L</PL_check> is global to an entire process, and a module wishing to
11202hook op checking may find itself invoked more than once per process,
11203typically in different threads. To handle that situation, this function
11204is idempotent. The location I<*old_checker_p> must initially (once
11205per process) contain a null pointer. A C variable of static duration
11206(declared at file scope, typically also marked C<static> to give
11207it internal linkage) will be implicitly initialised appropriately,
11208if it does not have an explicit initialiser. This function will only
11209actually modify the check chain if it finds I<*old_checker_p> to be null.
11210This function is also thread safe on the small scale. It uses appropriate
11211locking to avoid race conditions in accessing L</PL_check>.
11212
11213When this function is called, the function referenced by I<new_checker>
11214must be ready to be called, except for I<*old_checker_p> being unfilled.
11215In a threading situation, I<new_checker> may be called immediately,
11216even before this function has returned. I<*old_checker_p> will always
11217be appropriately set before I<new_checker> is called. If I<new_checker>
11218decides not to do anything special with an op that it is given (which
11219is the usual case for most uses of op check hooking), it must chain the
11220check function referenced by I<*old_checker_p>.
11221
11222If you want to influence compilation of calls to a specific subroutine,
11223then use L</cv_set_call_checker> rather than hooking checking of all
11224C<entersub> ops.
11225
11226=cut
11227*/
11228
11229void
11230Perl_wrap_op_checker(pTHX_ Optype opcode,
11231 Perl_check_t new_checker, Perl_check_t *old_checker_p)
11232{
9b11155f
TC		 11233 dVAR;
11234
e8570548
Z		 11235 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
11236 if (*old_checker_p) return;
11237 OP_CHECK_MUTEX_LOCK;
11238 if (!*old_checker_p) {
11239 *old_checker_p = PL_check[opcode];
11240 PL_check[opcode] = new_checker;
11241 }
11242 OP_CHECK_MUTEX_UNLOCK;
11243}
11244
beab0874
JT		 11245#include "XSUB.h"
11246
11247/* Efficient sub that returns a constant scalar value. */
11248static void
acfe0abc 11249const_sv_xsub(pTHX_ CV* cv)
beab0874 11250{
97aff369 11251 dVAR;
beab0874 11252 dXSARGS;
99ab892b 11253 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9cbac4c7 11254 if (items != 0) {
6f207bd3 11255 NOOP;
9cbac4c7 11256#if 0
fe13d51d 11257 /* diag_listed_as: SKIPME */
9cbac4c7 11258 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 11259 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 11260#endif
11261 }
99ab892b
NC		 11262 if (!sv) {
11263 XSRETURN(0);
11264 }
9a049f1c 11265 EXTEND(sp, 1);
99ab892b 11266 ST(0) = sv;
beab0874
JT		 11267 XSRETURN(1);
11268}
4946a0fa
NC		 11269
11270/*
11271 * Local variables:
11272 * c-indentation-style: bsd
11273 * c-basic-offset: 4
14d04a33 11274 * indent-tabs-mode: nil
4946a0fa
NC		 11275 * End:
11276 *
14d04a33 11277 * ex: set ts=8 sts=4 sw=4 et:
37442d52 11278 */
Unnamed repository; edit this file 'description' to name the repository.