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