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
A test to check that regen.pl doesn't need running.
[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
2474a784
FC		 2239 ismatchop = (rtype == OP_MATCH ||
2240 rtype == OP_SUBST ||
2241 rtype == OP_TRANS)
2242 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS		 2243 if (ismatchop && right->op_private & OPpTARGET_MY) {
2244 right->op_targ = 0;
2245 right->op_private &= ~OPpTARGET_MY;
2246 }
2247 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2248 OP *newleft;
2249
79072805 2250 right->op_flags |= OPf_STACKED;
1496a290
AL		 2251 if (rtype != OP_MATCH &&
2252 ! (rtype == OP_TRANS &&
4f4d7508
DC		 2253 right->op_private & OPpTRANS_IDENTICAL) &&
2254 ! (rtype == OP_SUBST &&
2255 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
1496a290
AL		 2256 newleft = mod(left, rtype);
2257 else
2258 newleft = left;
79072805 2259 if (right->op_type == OP_TRANS)
1496a290 2260 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2261 else
1496a290 2262 o = prepend_elem(rtype, scalar(newleft), right);
79072805 2263 if (type == OP_NOT)
11343788
MB		 2264 return newUNOP(OP_NOT, 0, scalar(o));
2265 return o;
79072805
LW		 2266 }
2267 else
2268 return bind_match(type, left,
131b3ad0 2269 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 2270}
2271
2272OP *
864dbfa3 2273Perl_invert(pTHX_ OP *o)
79072805 2274{
11343788 2275 if (!o)
1d866c12 2276 return NULL;
11343788 2277 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2278}
2279
2280OP *
864dbfa3 2281Perl_scope(pTHX_ OP *o)
79072805 2282{
27da23d5 2283 dVAR;
79072805 2284 if (o) {
3280af22 2285 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 2286 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2287 o->op_type = OP_LEAVE;
22c35a8c 2288 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2289 }
fdb22418
HS		 2290 else if (o->op_type == OP_LINESEQ) {
2291 OP *kid;
2292 o->op_type = OP_SCOPE;
2293 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2294 kid = ((LISTOP*)o)->op_first;
59110972 2295 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2296 op_null(kid);
59110972
RH		 2297
2298 /* The following deals with things like 'do {1 for 1}' */
2299 kid = kid->op_sibling;
2300 if (kid &&
2301 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2302 op_null(kid);
2303 }
463ee0b2 2304 }
fdb22418 2305 else
5f66b61c 2306 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2307 }
2308 return o;
2309}
1930840b 2310
a0d0e21e 2311int
864dbfa3 2312Perl_block_start(pTHX_ int full)
79072805 2313{
97aff369 2314 dVAR;
73d840c0 2315 const int retval = PL_savestack_ix;
1930840b 2316
dd2155a4 2317 pad_block_start(full);
b3ac6de7 2318 SAVEHINTS();
3280af22 2319 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2320 SAVECOMPILEWARNINGS();
72dc9ed5 2321 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b
BM		 2322
2323 CALL_BLOCK_HOOKS(start, full);
2324
a0d0e21e
LW		 2325 return retval;
2326}
2327
2328OP*
864dbfa3 2329Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2330{
97aff369 2331 dVAR;
6867be6d 2332 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b
BM		 2333 OP* retval = scalarseq(seq);
2334
2335 CALL_BLOCK_HOOKS(pre_end, &retval);
2336
e9818f4e 2337 LEAVE_SCOPE(floor);
623e6609 2338 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2339 if (needblockscope)
3280af22 2340 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 2341 pad_leavemy();
1930840b
BM		 2342
2343 CALL_BLOCK_HOOKS(post_end, &retval);
2344
a0d0e21e
LW		 2345 return retval;
2346}
2347
fd85fad2
BM		 2348/*
2349=head1 Compile-time scope hooks
2350
2351=for apidoc Ao||blockhook_register
2352
2353Register a set of hooks to be called when the Perl lexical scope changes
2354at compile time. See L<perlguts/"Compile-time scope hooks">.
2355
2356=cut
2357*/
2358
bb6c22e7
BM		 2359void
2360Perl_blockhook_register(pTHX_ BHK *hk)
2361{
2362 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2363
2364 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2365}
2366
76e3520e 2367STATIC OP *
cea2e8a9 2368S_newDEFSVOP(pTHX)
54b9620d 2369{
97aff369 2370 dVAR;
f8f98e0a 2371 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
00b1698f 2372 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2373 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2374 }
2375 else {
551405c4 2376 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2377 o->op_targ = offset;
2378 return o;
2379 }
54b9620d
MB		 2380}
2381
a0d0e21e 2382void
864dbfa3 2383Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2384{
97aff369 2385 dVAR;
7918f24d
NC		 2386
2387 PERL_ARGS_ASSERT_NEWPROG;
2388
3280af22 2389 if (PL_in_eval) {
b295d113
TH		 2390 if (PL_eval_root)
2391 return;
faef0170
HS		 2392 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2393 ((PL_in_eval & EVAL_KEEPERR)
2394 ? OPf_SPECIAL : 0), o);
3280af22 2395 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 2396 PL_eval_root->op_private |= OPpREFCOUNTED;
2397 OpREFCNT_set(PL_eval_root, 1);
3280af22 2398 PL_eval_root->op_next = 0;
a2efc822 2399 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 2400 }
2401 else {
6be89cf9
AE		 2402 if (o->op_type == OP_STUB) {
2403 PL_comppad_name = 0;
2404 PL_compcv = 0;
d2c837a0 2405 S_op_destroy(aTHX_ o);
a0d0e21e 2406 return;
6be89cf9 2407 }
3280af22
NIS		 2408 PL_main_root = scope(sawparens(scalarvoid(o)));
2409 PL_curcop = &PL_compiling;
2410 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2411 PL_main_root->op_private |= OPpREFCOUNTED;
2412 OpREFCNT_set(PL_main_root, 1);
3280af22 2413 PL_main_root->op_next = 0;
a2efc822 2414 CALL_PEEP(PL_main_start);
3280af22 2415 PL_compcv = 0;
3841441e 2416
4fdae800 2417 /* Register with debugger */
84902520 2418 if (PERLDB_INTER) {
b96d8cd9 2419 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS		 2420 if (cv) {
2421 dSP;
924508f0 2422 PUSHMARK(SP);
ad64d0ec 2423 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 2424 PUTBACK;
ad64d0ec 2425 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS		 2426 }
2427 }
79072805 2428 }
79072805
LW		 2429}
2430
2431OP *
864dbfa3 2432Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2433{
97aff369 2434 dVAR;
7918f24d
NC		 2435
2436 PERL_ARGS_ASSERT_LOCALIZE;
2437
79072805 2438 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2439/* [perl #17376]: this appears to be premature, and results in code such as
2440 C< our(%x); > executing in list mode rather than void mode */
2441#if 0
79072805 2442 list(o);
d2be0de5 2443#else
6f207bd3 2444 NOOP;
d2be0de5 2445#endif
8990e307 2446 else {
f06b5848
DM		 2447 if ( PL_parser->bufptr > PL_parser->oldbufptr
2448 && PL_parser->bufptr[-1] == ','
041457d9 2449 && ckWARN(WARN_PARENTHESIS))
64420d0d 2450 {
f06b5848 2451 char *s = PL_parser->bufptr;
bac662ee 2452 bool sigil = FALSE;
64420d0d 2453
8473848f 2454 /* some heuristics to detect a potential error */
bac662ee 2455 while (*s && (strchr(", \t\n", *s)))
64420d0d 2456 s++;
8473848f 2457
bac662ee
TS		 2458 while (1) {
2459 if (*s && strchr("@$%*", *s) && *++s
2460 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2461 s++;
2462 sigil = TRUE;
2463 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2464 s++;
2465 while (*s && (strchr(", \t\n", *s)))
2466 s++;
2467 }
2468 else
2469 break;
2470 }
2471 if (sigil && (*s == ';' || *s == '=')) {
2472 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 2473 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 2474 lex
2475 ? (PL_parser->in_my == KEY_our
2476 ? "our"
2477 : PL_parser->in_my == KEY_state
2478 ? "state"
2479 : "my")
2480 : "local");
8473848f 2481 }
8990e307
LW		 2482 }
2483 }
93a17b20 2484 if (lex)
eb64745e 2485 o = my(o);
93a17b20 2486 else
eb64745e 2487 o = mod(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 2488 PL_parser->in_my = FALSE;
2489 PL_parser->in_my_stash = NULL;
eb64745e 2490 return o;
79072805
LW		 2491}
2492
2493OP *
864dbfa3 2494Perl_jmaybe(pTHX_ OP *o)
79072805 2495{
7918f24d
NC		 2496 PERL_ARGS_ASSERT_JMAYBE;
2497
79072805 2498 if (o->op_type == OP_LIST) {
fafc274c 2499 OP * const o2
d4c19fe8 2500 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
554b3eca 2501 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2502 }
2503 return o;
2504}
2505
1f676739 2506static OP *
b7783a12 2507S_fold_constants(pTHX_ register OP *o)
79072805 2508{
27da23d5 2509 dVAR;
001d637e 2510 register OP * VOL curop;
eb8433b7 2511 OP *newop;
8ea43dc8 2512 VOL I32 type = o->op_type;
e3cbe32f 2513 SV * VOL sv = NULL;
b7f7fd0b
NC		 2514 int ret = 0;
2515 I32 oldscope;
2516 OP *old_next;
5f2d9966
DM		 2517 SV * const oldwarnhook = PL_warnhook;
2518 SV * const olddiehook = PL_diehook;
c427f4d2 2519 COP not_compiling;
b7f7fd0b 2520 dJMPENV;
79072805 2521
7918f24d
NC		 2522 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2523
22c35a8c 2524 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2525 scalar(o);
b162f9ea 2526 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2527 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2528
eac055e9
GS		 2529 /* integerize op, unless it happens to be C<-foo>.
2530 * XXX should pp_i_negate() do magic string negation instead? */
2531 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2532 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2533 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2534 {
22c35a8c 2535 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2536 }
85e6fe83 2537
22c35a8c 2538 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2539 goto nope;
2540
de939608 2541 switch (type) {
7a52d87a
GS		 2542 case OP_NEGATE:
2543 /* XXX might want a ck_negate() for this */
2544 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2545 break;
de939608
CS		 2546 case OP_UCFIRST:
2547 case OP_LCFIRST:
2548 case OP_UC:
2549 case OP_LC:
69dcf70c
MB		 2550 case OP_SLT:
2551 case OP_SGT:
2552 case OP_SLE:
2553 case OP_SGE:
2554 case OP_SCMP:
2de3dbcc
JH		 2555 /* XXX what about the numeric ops? */
2556 if (PL_hints & HINT_LOCALE)
de939608 2557 goto nope;
553e7bb0 2558 break;
de939608
CS		 2559 }
2560
13765c85 2561 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 2562 goto nope; /* Don't try to run w/ errors */
2563
79072805 2564 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 2565 const OPCODE type = curop->op_type;
2566 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2567 type != OP_LIST &&
2568 type != OP_SCALAR &&
2569 type != OP_NULL &&
2570 type != OP_PUSHMARK)
7a52d87a 2571 {
79072805
LW		 2572 goto nope;
2573 }
2574 }
2575
2576 curop = LINKLIST(o);
b7f7fd0b 2577 old_next = o->op_next;
79072805 2578 o->op_next = 0;
533c011a 2579 PL_op = curop;
b7f7fd0b
NC		 2580
2581 oldscope = PL_scopestack_ix;
edb2152a 2582 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 2583
c427f4d2
NC		 2584 /* Verify that we don't need to save it: */
2585 assert(PL_curcop == &PL_compiling);
2586 StructCopy(&PL_compiling, &not_compiling, COP);
2587 PL_curcop = &not_compiling;
2588 /* The above ensures that we run with all the correct hints of the
2589 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2590 assert(IN_PERL_RUNTIME);
5f2d9966
DM		 2591 PL_warnhook = PERL_WARNHOOK_FATAL;
2592 PL_diehook = NULL;
b7f7fd0b
NC		 2593 JMPENV_PUSH(ret);
2594
2595 switch (ret) {
2596 case 0:
2597 CALLRUNOPS(aTHX);
2598 sv = *(PL_stack_sp--);
2599 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2600 pad_swipe(o->op_targ, FALSE);
2601 else if (SvTEMP(sv)) { /* grab mortal temp? */
2602 SvREFCNT_inc_simple_void(sv);
2603 SvTEMP_off(sv);
2604 }
2605 break;
2606 case 3:
2607 /* Something tried to die. Abandon constant folding. */
2608 /* Pretend the error never happened. */
ab69dbc2 2609 CLEAR_ERRSV();
b7f7fd0b
NC		 2610 o->op_next = old_next;
2611 break;
2612 default:
2613 JMPENV_POP;
5f2d9966
DM		 2614 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2615 PL_warnhook = oldwarnhook;
2616 PL_diehook = olddiehook;
2617 /* XXX note that this croak may fail as we've already blown away
2618 * the stack - eg any nested evals */
b7f7fd0b
NC		 2619 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2620 }
b7f7fd0b 2621 JMPENV_POP;
5f2d9966
DM		 2622 PL_warnhook = oldwarnhook;
2623 PL_diehook = olddiehook;
c427f4d2 2624 PL_curcop = &PL_compiling;
edb2152a
NC		 2625
2626 if (PL_scopestack_ix > oldscope)
2627 delete_eval_scope();
eb8433b7 2628
b7f7fd0b
NC		 2629 if (ret)
2630 goto nope;
2631
eb8433b7 2632#ifndef PERL_MAD
79072805 2633 op_free(o);
eb8433b7 2634#endif
de5e01c2 2635 assert(sv);
79072805 2636 if (type == OP_RV2GV)
159b6efe 2637 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 2638 else
ad64d0ec 2639 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
eb8433b7
NC		 2640 op_getmad(o,newop,'f');
2641 return newop;
aeea060c 2642
b7f7fd0b 2643 nope:
79072805
LW		 2644 return o;
2645}
2646
1f676739 2647static OP *
b7783a12 2648S_gen_constant_list(pTHX_ register OP *o)
79072805 2649{
27da23d5 2650 dVAR;
79072805 2651 register OP *curop;
6867be6d 2652 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2653
a0d0e21e 2654 list(o);
13765c85 2655 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 2656 return o; /* Don't attempt to run with errors */
2657
533c011a 2658 PL_op = curop = LINKLIST(o);
a0d0e21e 2659 o->op_next = 0;
a2efc822 2660 CALL_PEEP(curop);
cea2e8a9
GS		 2661 pp_pushmark();
2662 CALLRUNOPS(aTHX);
533c011a 2663 PL_op = curop;
78c72037
NC		 2664 assert (!(curop->op_flags & OPf_SPECIAL));
2665 assert(curop->op_type == OP_RANGE);
cea2e8a9 2666 pp_anonlist();
3280af22 2667 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2668
2669 o->op_type = OP_RV2AV;
22c35a8c 2670 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2671 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2672 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 2673 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 2674 curop = ((UNOP*)o)->op_first;
b37c2d43 2675 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 2676#ifdef PERL_MAD
2677 op_getmad(curop,o,'O');
2678#else
79072805 2679 op_free(curop);
eb8433b7 2680#endif
79072805
LW		 2681 linklist(o);
2682 return list(o);
2683}
2684
2685OP *
864dbfa3 2686Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2687{
27da23d5 2688 dVAR;
11343788 2689 if (!o || o->op_type != OP_LIST)
5f66b61c 2690 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 2691 else
5dc0d613 2692 o->op_flags &= ~OPf_WANT;
79072805 2693
22c35a8c 2694 if (!(PL_opargs[type] & OA_MARK))
93c66552 2695 op_null(cLISTOPo->op_first);
8990e307 2696
eb160463 2697 o->op_type = (OPCODE)type;
22c35a8c 2698 o->op_ppaddr = PL_ppaddr[type];
11343788 2699 o->op_flags |= flags;
79072805 2700
11343788 2701 o = CHECKOP(type, o);
fe2774ed 2702 if (o->op_type != (unsigned)type)
11343788 2703 return o;
79072805 2704
11343788 2705 return fold_constants(o);
79072805
LW		 2706}
2707
2708/* List constructors */
2709
2710OP *
864dbfa3 2711Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2712{
2713 if (!first)
2714 return last;
8990e307
LW		 2715
2716 if (!last)
79072805 2717 return first;
8990e307 2718
fe2774ed 2719 if (first->op_type != (unsigned)type
155aba94
GS		 2720 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2721 {
2722 return newLISTOP(type, 0, first, last);
2723 }
79072805 2724
a0d0e21e
LW		 2725 if (first->op_flags & OPf_KIDS)
2726 ((LISTOP*)first)->op_last->op_sibling = last;
2727 else {
2728 first->op_flags |= OPf_KIDS;
2729 ((LISTOP*)first)->op_first = last;
2730 }
2731 ((LISTOP*)first)->op_last = last;
a0d0e21e 2732 return first;
79072805
LW		 2733}
2734
2735OP *
864dbfa3 2736Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2737{
2738 if (!first)
2739 return (OP*)last;
8990e307
LW		 2740
2741 if (!last)
79072805 2742 return (OP*)first;
8990e307 2743
fe2774ed 2744 if (first->op_type != (unsigned)type)
79072805 2745 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2746
fe2774ed 2747 if (last->op_type != (unsigned)type)
79072805
LW		 2748 return append_elem(type, (OP*)first, (OP*)last);
2749
2750 first->op_last->op_sibling = last->op_first;
2751 first->op_last = last->op_last;
117dada2 2752 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2753
eb8433b7
NC		 2754#ifdef PERL_MAD
2755 if (last->op_first && first->op_madprop) {
2756 MADPROP *mp = last->op_first->op_madprop;
2757 if (mp) {
2758 while (mp->mad_next)
2759 mp = mp->mad_next;
2760 mp->mad_next = first->op_madprop;
2761 }
2762 else {
2763 last->op_first->op_madprop = first->op_madprop;
2764 }
2765 }
2766 first->op_madprop = last->op_madprop;
2767 last->op_madprop = 0;
2768#endif
2769
d2c837a0 2770 S_op_destroy(aTHX_ (OP*)last);
238a4c30 2771
79072805
LW		 2772 return (OP*)first;
2773}
2774
2775OP *
864dbfa3 2776Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2777{
2778 if (!first)
2779 return last;
8990e307
LW		 2780
2781 if (!last)
79072805 2782 return first;
8990e307 2783
fe2774ed 2784 if (last->op_type == (unsigned)type) {
8990e307
LW		 2785 if (type == OP_LIST) { /* already a PUSHMARK there */
2786 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2787 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2788 if (!(first->op_flags & OPf_PARENS))
2789 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2790 }
2791 else {
2792 if (!(last->op_flags & OPf_KIDS)) {
2793 ((LISTOP*)last)->op_last = first;
2794 last->op_flags |= OPf_KIDS;
2795 }
2796 first->op_sibling = ((LISTOP*)last)->op_first;
2797 ((LISTOP*)last)->op_first = first;
79072805 2798 }
117dada2 2799 last->op_flags |= OPf_KIDS;
79072805
LW		 2800 return last;
2801 }
2802
2803 return newLISTOP(type, 0, first, last);
2804}
2805
2806/* Constructors */
2807
eb8433b7
NC		 2808#ifdef PERL_MAD
2809
2810TOKEN *
2811Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2812{
2813 TOKEN *tk;
99129197 2814 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 2815 tk->tk_type = (OPCODE)optype;
2816 tk->tk_type = 12345;
2817 tk->tk_lval = lval;
2818 tk->tk_mad = madprop;
2819 return tk;
2820}
2821
2822void
2823Perl_token_free(pTHX_ TOKEN* tk)
2824{
7918f24d
NC		 2825 PERL_ARGS_ASSERT_TOKEN_FREE;
2826
eb8433b7
NC		 2827 if (tk->tk_type != 12345)
2828 return;
2829 mad_free(tk->tk_mad);
2830 Safefree(tk);
2831}
2832
2833void
2834Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2835{
2836 MADPROP* mp;
2837 MADPROP* tm;
7918f24d
NC		 2838
2839 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2840
eb8433b7
NC		 2841 if (tk->tk_type != 12345) {
2842 Perl_warner(aTHX_ packWARN(WARN_MISC),
2843 "Invalid TOKEN object ignored");
2844 return;
2845 }
2846 tm = tk->tk_mad;
2847 if (!tm)
2848 return;
2849
2850 /* faked up qw list? */
2851 if (slot == '(' &&
2852 tm->mad_type == MAD_SV &&
d503a9ba 2853 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC		 2854 slot = 'x';
2855
2856 if (o) {
2857 mp = o->op_madprop;
2858 if (mp) {
2859 for (;;) {
2860 /* pretend constant fold didn't happen? */
2861 if (mp->mad_key == 'f' &&
2862 (o->op_type == OP_CONST ||
2863 o->op_type == OP_GV) )
2864 {
2865 token_getmad(tk,(OP*)mp->mad_val,slot);
2866 return;
2867 }
2868 if (!mp->mad_next)
2869 break;
2870 mp = mp->mad_next;
2871 }
2872 mp->mad_next = tm;
2873 mp = mp->mad_next;
2874 }
2875 else {
2876 o->op_madprop = tm;
2877 mp = o->op_madprop;
2878 }
2879 if (mp->mad_key == 'X')
2880 mp->mad_key = slot; /* just change the first one */
2881
2882 tk->tk_mad = 0;
2883 }
2884 else
2885 mad_free(tm);
2886 Safefree(tk);
2887}
2888
2889void
2890Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2891{
2892 MADPROP* mp;
2893 if (!from)
2894 return;
2895 if (o) {
2896 mp = o->op_madprop;
2897 if (mp) {
2898 for (;;) {
2899 /* pretend constant fold didn't happen? */
2900 if (mp->mad_key == 'f' &&
2901 (o->op_type == OP_CONST ||
2902 o->op_type == OP_GV) )
2903 {
2904 op_getmad(from,(OP*)mp->mad_val,slot);
2905 return;
2906 }
2907 if (!mp->mad_next)
2908 break;
2909 mp = mp->mad_next;
2910 }
2911 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2912 }
2913 else {
2914 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2915 }
2916 }
2917}
2918
2919void
2920Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2921{
2922 MADPROP* mp;
2923 if (!from)
2924 return;
2925 if (o) {
2926 mp = o->op_madprop;
2927 if (mp) {
2928 for (;;) {
2929 /* pretend constant fold didn't happen? */
2930 if (mp->mad_key == 'f' &&
2931 (o->op_type == OP_CONST ||
2932 o->op_type == OP_GV) )
2933 {
2934 op_getmad(from,(OP*)mp->mad_val,slot);
2935 return;
2936 }
2937 if (!mp->mad_next)
2938 break;
2939 mp = mp->mad_next;
2940 }
2941 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2942 }
2943 else {
2944 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2945 }
2946 }
2947 else {
99129197
NC		 2948 PerlIO_printf(PerlIO_stderr(),
2949 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 2950 op_free(from);
2951 }
2952}
2953
2954void
2955Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2956{
2957 MADPROP* tm;
2958 if (!mp || !o)
2959 return;
2960 if (slot)
2961 mp->mad_key = slot;
2962 tm = o->op_madprop;
2963 o->op_madprop = mp;
2964 for (;;) {
2965 if (!mp->mad_next)
2966 break;
2967 mp = mp->mad_next;
2968 }
2969 mp->mad_next = tm;
2970}
2971
2972void
2973Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2974{
2975 if (!o)
2976 return;
2977 addmad(tm, &(o->op_madprop), slot);
2978}
2979
2980void
2981Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2982{
2983 MADPROP* mp;
2984 if (!tm || !root)
2985 return;
2986 if (slot)
2987 tm->mad_key = slot;
2988 mp = *root;
2989 if (!mp) {
2990 *root = tm;
2991 return;
2992 }
2993 for (;;) {
2994 if (!mp->mad_next)
2995 break;
2996 mp = mp->mad_next;
2997 }
2998 mp->mad_next = tm;
2999}
3000
3001MADPROP *
3002Perl_newMADsv(pTHX_ char key, SV* sv)
3003{
7918f24d
NC		 3004 PERL_ARGS_ASSERT_NEWMADSV;
3005
eb8433b7
NC		 3006 return newMADPROP(key, MAD_SV, sv, 0);
3007}
3008
3009MADPROP *
d503a9ba 3010Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7
NC		 3011{
3012 MADPROP *mp;
99129197 3013 Newxz(mp, 1, MADPROP);
eb8433b7
NC		 3014 mp->mad_next = 0;
3015 mp->mad_key = key;
3016 mp->mad_vlen = vlen;
3017 mp->mad_type = type;
3018 mp->mad_val = val;
3019/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3020 return mp;
3021}
3022
3023void
3024Perl_mad_free(pTHX_ MADPROP* mp)
3025{
3026/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3027 if (!mp)
3028 return;
3029 if (mp->mad_next)
3030 mad_free(mp->mad_next);
bc177e6b 3031/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC		 3032 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3033 switch (mp->mad_type) {
3034 case MAD_NULL:
3035 break;
3036 case MAD_PV:
3037 Safefree((char*)mp->mad_val);
3038 break;
3039 case MAD_OP:
3040 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3041 op_free((OP*)mp->mad_val);
3042 break;
3043 case MAD_SV:
ad64d0ec 3044 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC		 3045 break;
3046 default:
3047 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3048 break;
3049 }
3050 Safefree(mp);
3051}
3052
3053#endif
3054
d67eb5f4
Z		 3055/*
3056=head1 Optree construction
3057
3058=for apidoc Am|OP *|newNULLLIST
3059
3060Constructs, checks, and returns a new C<stub> op, which represents an
3061empty list expression.
3062
3063=cut
3064*/
3065
79072805 3066OP *
864dbfa3 3067Perl_newNULLLIST(pTHX)
79072805 3068{
8990e307
LW		 3069 return newOP(OP_STUB, 0);
3070}
3071
1f676739 3072static OP *
b7783a12 3073S_force_list(pTHX_ OP *o)
8990e307 3074{
11343788 3075 if (!o || o->op_type != OP_LIST)
5f66b61c 3076 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 3077 op_null(o);
11343788 3078 return o;
79072805
LW		 3079}
3080
d67eb5f4
Z		 3081/*
3082=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3083
3084Constructs, checks, and returns an op of any list type. I<type> is
3085the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3086C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3087supply up to two ops to be direct children of the list op; they are
3088consumed by this function and become part of the constructed op tree.
3089
3090=cut
3091*/
3092
79072805 3093OP *
864dbfa3 3094Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3095{
27da23d5 3096 dVAR;
79072805
LW		 3097 LISTOP *listop;
3098
e69777c1
GG		 3099 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3100
b7dc083c 3101 NewOp(1101, listop, 1, LISTOP);
79072805 3102
eb160463 3103 listop->op_type = (OPCODE)type;
22c35a8c 3104 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 3105 if (first || last)
3106 flags |= OPf_KIDS;
eb160463 3107 listop->op_flags = (U8)flags;
79072805
LW		 3108
3109 if (!last && first)
3110 last = first;
3111 else if (!first && last)
3112 first = last;
8990e307
LW		 3113 else if (first)
3114 first->op_sibling = last;
79072805
LW		 3115 listop->op_first = first;
3116 listop->op_last = last;
8990e307 3117 if (type == OP_LIST) {
551405c4 3118 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 3119 pushop->op_sibling = first;
3120 listop->op_first = pushop;
3121 listop->op_flags |= OPf_KIDS;
3122 if (!last)
3123 listop->op_last = pushop;
3124 }
79072805 3125
463d09e6 3126 return CHECKOP(type, listop);
79072805
LW		 3127}
3128
d67eb5f4
Z		 3129/*
3130=for apidoc Am|OP *|newOP|I32 type|I32 flags
3131
3132Constructs, checks, and returns an op of any base type (any type that
3133has no extra fields). I<type> is the opcode. I<flags> gives the
3134eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3135of C<op_private>.
3136
3137=cut
3138*/
3139
79072805 3140OP *
864dbfa3 3141Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 3142{
27da23d5 3143 dVAR;
11343788 3144 OP *o;
e69777c1
GG		 3145
3146 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3147 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3148 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3149 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3150
b7dc083c 3151 NewOp(1101, o, 1, OP);
eb160463 3152 o->op_type = (OPCODE)type;
22c35a8c 3153 o->op_ppaddr = PL_ppaddr[type];
eb160463 3154 o->op_flags = (U8)flags;
670f3923
DM		 3155 o->op_latefree = 0;
3156 o->op_latefreed = 0;
7e5d8ed2 3157 o->op_attached = 0;
79072805 3158
11343788 3159 o->op_next = o;
eb160463 3160 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 3161 if (PL_opargs[type] & OA_RETSCALAR)
11343788 3162 scalar(o);
22c35a8c 3163 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 3164 o->op_targ = pad_alloc(type, SVs_PADTMP);
3165 return CHECKOP(type, o);
79072805
LW		 3166}
3167
d67eb5f4
Z		 3168/*
3169=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3170
3171Constructs, checks, and returns an op of any unary type. I<type> is
3172the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3173C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3174bits, the eight bits of C<op_private>, except that the bit with value 1
3175is automatically set. I<first> supplies an optional op to be the direct
3176child of the unary op; it is consumed by this function and become part
3177of the constructed op tree.
3178
3179=cut
3180*/
3181
79072805 3182OP *
864dbfa3 3183Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 3184{
27da23d5 3185 dVAR;
79072805
LW		 3186 UNOP *unop;
3187
e69777c1
GG		 3188 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3189 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3190 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3191 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3192 || type == OP_SASSIGN
32e2a35d 3193 || type == OP_ENTERTRY
e69777c1
GG		 3194 || type == OP_NULL );
3195
93a17b20 3196 if (!first)
aeea060c 3197 first = newOP(OP_STUB, 0);
22c35a8c 3198 if (PL_opargs[type] & OA_MARK)
8990e307 3199 first = force_list(first);
93a17b20 3200
b7dc083c 3201 NewOp(1101, unop, 1, UNOP);
eb160463 3202 unop->op_type = (OPCODE)type;
22c35a8c 3203 unop->op_ppaddr = PL_ppaddr[type];
79072805 3204 unop->op_first = first;
585ec06d 3205 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 3206 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 3207 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 3208 if (unop->op_next)
3209 return (OP*)unop;
3210
a0d0e21e 3211 return fold_constants((OP *) unop);
79072805
LW		 3212}
3213
d67eb5f4
Z		 3214/*
3215=for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3216
3217Constructs, checks, and returns an op of any binary type. I<type>
3218is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3219that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3220the eight bits of C<op_private>, except that the bit with value 1 or
32212 is automatically set as required. I<first> and I<last> supply up to
3222two ops to be the direct children of the binary op; they are consumed
3223by this function and become part of the constructed op tree.
3224
3225=cut
3226*/
3227
79072805 3228OP *
864dbfa3 3229Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3230{
27da23d5 3231 dVAR;
79072805 3232 BINOP *binop;
e69777c1
GG		 3233
3234 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3235 || type == OP_SASSIGN || type == OP_NULL );
3236
b7dc083c 3237 NewOp(1101, binop, 1, BINOP);
79072805
LW		 3238
3239 if (!first)
3240 first = newOP(OP_NULL, 0);
3241
eb160463 3242 binop->op_type = (OPCODE)type;
22c35a8c 3243 binop->op_ppaddr = PL_ppaddr[type];
79072805 3244 binop->op_first = first;
585ec06d 3245 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 3246 if (!last) {
3247 last = first;
eb160463 3248 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3249 }
3250 else {
eb160463 3251 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 3252 first->op_sibling = last;
3253 }
3254
e50aee73 3255 binop = (BINOP*)CHECKOP(type, binop);
eb160463 3256 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 3257 return (OP*)binop;
3258
7284ab6f 3259 binop->op_last = binop->op_first->op_sibling;
79072805 3260
a0d0e21e 3261 return fold_constants((OP *)binop);
79072805
LW		 3262}
3263
5f66b61c
AL		 3264static int uvcompare(const void *a, const void *b)
3265 __attribute__nonnull__(1)
3266 __attribute__nonnull__(2)
3267 __attribute__pure__;
abb2c242 3268static int uvcompare(const void *a, const void *b)
2b9d42f0 3269{
e1ec3a88 3270 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 3271 return -1;
e1ec3a88 3272 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 3273 return 1;
e1ec3a88 3274 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 3275 return -1;
e1ec3a88 3276 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 3277 return 1;
a0ed51b3
LW		 3278 return 0;
3279}
3280
0d86688d
NC		 3281static OP *
3282S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 3283{
97aff369 3284 dVAR;
2d03de9c 3285 SV * const tstr = ((SVOP*)expr)->op_sv;
fbbb0949
DM		 3286 SV * const rstr =
3287#ifdef PERL_MAD
3288 (repl->op_type == OP_NULL)
3289 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3290#endif
3291 ((SVOP*)repl)->op_sv;
463ee0b2
LW		 3292 STRLEN tlen;
3293 STRLEN rlen;
5c144d81
NC		 3294 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3295 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 3296 register I32 i;
3297 register I32 j;
9b877dbb 3298 I32 grows = 0;
79072805
LW		 3299 register short *tbl;
3300
551405c4
AL		 3301 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3302 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3303 I32 del = o->op_private & OPpTRANS_DELETE;
043e41b8 3304 SV* swash;
7918f24d
NC		 3305
3306 PERL_ARGS_ASSERT_PMTRANS;
3307
800b4dc4 3308 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 3309
036b4402
GS		 3310 if (SvUTF8(tstr))
3311 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 3312
3313 if (SvUTF8(rstr))
036b4402 3314 o->op_private |= OPpTRANS_TO_UTF;
79072805 3315
a0ed51b3 3316 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 3317 SV* const listsv = newSVpvs("# comment\n");
c445ea15 3318 SV* transv = NULL;
5c144d81
NC		 3319 const U8* tend = t + tlen;
3320 const U8* rend = r + rlen;
ba210ebe 3321 STRLEN ulen;
84c133a0
RB		 3322 UV tfirst = 1;
3323 UV tlast = 0;
3324 IV tdiff;
3325 UV rfirst = 1;
3326 UV rlast = 0;
3327 IV rdiff;
3328 IV diff;
a0ed51b3
LW		 3329 I32 none = 0;
3330 U32 max = 0;
3331 I32 bits;
a0ed51b3 3332 I32 havefinal = 0;
9c5ffd7c 3333 U32 final = 0;
551405c4
AL		 3334 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3335 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 3336 U8* tsave = NULL;
3337 U8* rsave = NULL;
9f7f3913 3338 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 3339
3340 if (!from_utf) {
3341 STRLEN len = tlen;
5c144d81 3342 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 3343 tend = t + len;
3344 }
3345 if (!to_utf && rlen) {
3346 STRLEN len = rlen;
5c144d81 3347 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 3348 rend = r + len;
3349 }
a0ed51b3 3350
2b9d42f0
NIS		 3351/* There are several snags with this code on EBCDIC:
3352 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3353 2. scan_const() in toke.c has encoded chars in native encoding which makes
3354 ranges at least in EBCDIC 0..255 range the bottom odd.
3355*/
3356
a0ed51b3 3357 if (complement) {
89ebb4a3 3358 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 3359 UV *cp;
a0ed51b3 3360 UV nextmin = 0;
a02a5408 3361 Newx(cp, 2*tlen, UV);
a0ed51b3 3362 i = 0;
396482e1 3363 transv = newSVpvs("");
a0ed51b3 3364 while (t < tend) {
9f7f3913 3365 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS		 3366 t += ulen;
3367 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 3368 t++;
9f7f3913 3369 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 3370 t += ulen;
a0ed51b3 3371 }
2b9d42f0
NIS		 3372 else {
3373 cp[2*i+1] = cp[2*i];
3374 }
3375 i++;
a0ed51b3 3376 }
2b9d42f0 3377 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 3378 for (j = 0; j < i; j++) {
2b9d42f0 3379 UV val = cp[2*j];
a0ed51b3
LW		 3380 diff = val - nextmin;
3381 if (diff > 0) {
9041c2e3 3382 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3383 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 3384 if (diff > 1) {
2b9d42f0 3385 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 3386 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 3387 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 3388 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 3389 }
3390 }
2b9d42f0 3391 val = cp[2*j+1];
a0ed51b3
LW		 3392 if (val >= nextmin)
3393 nextmin = val + 1;
3394 }
9041c2e3 3395 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3396 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 3397 {
3398 U8 range_mark = UTF_TO_NATIVE(0xff);
3399 sv_catpvn(transv, (char *)&range_mark, 1);
3400 }
b851fbc1
JH		 3401 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3402 UNICODE_ALLOW_SUPER);
dfe13c55 3403 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 3404 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 3405 tlen = SvCUR(transv);
3406 tend = t + tlen;
455d824a 3407 Safefree(cp);
a0ed51b3
LW		 3408 }
3409 else if (!rlen && !del) {
3410 r = t; rlen = tlen; rend = tend;
4757a243
LW		 3411 }
3412 if (!squash) {
05d340b8 3413 if ((!rlen && !del) || t == r ||
12ae5dfc 3414 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 3415 {
4757a243 3416 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 3417 }
a0ed51b3
LW		 3418 }
3419
3420 while (t < tend || tfirst <= tlast) {
3421 /* see if we need more "t" chars */
3422 if (tfirst > tlast) {
9f7f3913 3423 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 3424 t += ulen;
2b9d42f0 3425 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3426 t++;
9f7f3913 3427 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW		 3428 t += ulen;
3429 }
3430 else
3431 tlast = tfirst;
3432 }
3433
3434 /* now see if we need more "r" chars */
3435 if (rfirst > rlast) {
3436 if (r < rend) {
9f7f3913 3437 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 3438 r += ulen;
2b9d42f0 3439 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3440 r++;
9f7f3913 3441 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW		 3442 r += ulen;
3443 }
3444 else
3445 rlast = rfirst;
3446 }
3447 else {
3448 if (!havefinal++)
3449 final = rlast;
3450 rfirst = rlast = 0xffffffff;
3451 }
3452 }
3453
3454 /* now see which range will peter our first, if either. */
3455 tdiff = tlast - tfirst;
3456 rdiff = rlast - rfirst;
3457
3458 if (tdiff <= rdiff)
3459 diff = tdiff;
3460 else
3461 diff = rdiff;
3462
3463 if (rfirst == 0xffffffff) {
3464 diff = tdiff; /* oops, pretend rdiff is infinite */
3465 if (diff > 0)
894356b3
GS		 3466 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3467 (long)tfirst, (long)tlast);
a0ed51b3 3468 else
894356b3 3469 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 3470 }
3471 else {
3472 if (diff > 0)
894356b3
GS		 3473 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3474 (long)tfirst, (long)(tfirst + diff),
3475 (long)rfirst);
a0ed51b3 3476 else
894356b3
GS		 3477 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3478 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 3479
3480 if (rfirst + diff > max)
3481 max = rfirst + diff;
9b877dbb 3482 if (!grows)
45005bfb
JH		 3483 grows = (tfirst < rfirst &&
3484 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3485 rfirst += diff + 1;
a0ed51b3
LW		 3486 }
3487 tfirst += diff + 1;
3488 }
3489
3490 none = ++max;
3491 if (del)
3492 del = ++max;
3493
3494 if (max > 0xffff)
3495 bits = 32;
3496 else if (max > 0xff)
3497 bits = 16;
3498 else
3499 bits = 8;
3500
ea71c68d 3501 PerlMemShared_free(cPVOPo->op_pv);
b3123a61 3502 cPVOPo->op_pv = NULL;
043e41b8 3503
ad64d0ec 3504 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
043e41b8
DM		 3505#ifdef USE_ITHREADS
3506 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3507 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3508 PAD_SETSV(cPADOPo->op_padix, swash);
3509 SvPADTMP_on(swash);
a5446a64 3510 SvREADONLY_on(swash);
043e41b8
DM		 3511#else
3512 cSVOPo->op_sv = swash;
3513#endif
a0ed51b3 3514 SvREFCNT_dec(listsv);
b37c2d43 3515 SvREFCNT_dec(transv);
a0ed51b3 3516
45005bfb 3517 if (!del && havefinal && rlen)
85fbaab2 3518 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
b448e4fe 3519 newSVuv((UV)final), 0);
a0ed51b3 3520
9b877dbb 3521 if (grows)
a0ed51b3
LW		 3522 o->op_private |= OPpTRANS_GROWS;
3523
b37c2d43
AL		 3524 Safefree(tsave);
3525 Safefree(rsave);
9b877dbb 3526
eb8433b7
NC		 3527#ifdef PERL_MAD
3528 op_getmad(expr,o,'e');
3529 op_getmad(repl,o,'r');
3530#else
a0ed51b3
LW		 3531 op_free(expr);
3532 op_free(repl);
eb8433b7 3533#endif
a0ed51b3
LW		 3534 return o;
3535 }
3536
3537 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 3538 if (complement) {
3539 Zero(tbl, 256, short);
eb160463 3540 for (i = 0; i < (I32)tlen; i++)
ec49126f 3541 tbl[t[i]] = -1;
79072805
LW		 3542 for (i = 0, j = 0; i < 256; i++) {
3543 if (!tbl[i]) {
eb160463 3544 if (j >= (I32)rlen) {
a0ed51b3 3545 if (del)
79072805
LW		 3546 tbl[i] = -2;
3547 else if (rlen)
ec49126f 3548 tbl[i] = r[j-1];
79072805 3549 else
eb160463 3550 tbl[i] = (short)i;
79072805 3551 }
9b877dbb
IH		 3552 else {
3553 if (i < 128 && r[j] >= 128)
3554 grows = 1;
ec49126f 3555 tbl[i] = r[j++];
9b877dbb 3556 }
79072805
LW		 3557 }
3558 }
05d340b8
JH		 3559 if (!del) {
3560 if (!rlen) {
3561 j = rlen;
3562 if (!squash)
3563 o->op_private |= OPpTRANS_IDENTICAL;
3564 }
eb160463 3565 else if (j >= (I32)rlen)
05d340b8 3566 j = rlen - 1;
10db182f 3567 else {
aa1f7c5b
JH		 3568 tbl =
3569 (short *)
3570 PerlMemShared_realloc(tbl,
3571 (0x101+rlen-j) * sizeof(short));
10db182f
YO		 3572 cPVOPo->op_pv = (char*)tbl;
3573 }
585ec06d 3574 tbl[0x100] = (short)(rlen - j);
eb160463 3575 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 3576 tbl[0x101+i] = r[j+i];
3577 }
79072805
LW		 3578 }
3579 else {
a0ed51b3 3580 if (!rlen && !del) {
79072805 3581 r = t; rlen = tlen;
5d06d08e 3582 if (!squash)
4757a243 3583 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3584 }
94bfe852
RGS		 3585 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3586 o->op_private |= OPpTRANS_IDENTICAL;
3587 }
79072805
LW		 3588 for (i = 0; i < 256; i++)
3589 tbl[i] = -1;
eb160463
GS		 3590 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3591 if (j >= (I32)rlen) {
a0ed51b3 3592 if (del) {
ec49126f 3593 if (tbl[t[i]] == -1)
3594 tbl[t[i]] = -2;
79072805
LW		 3595 continue;
3596 }
3597 --j;
3598 }
9b877dbb
IH		 3599 if (tbl[t[i]] == -1) {
3600 if (t[i] < 128 && r[j] >= 128)
3601 grows = 1;
ec49126f 3602 tbl[t[i]] = r[j];
9b877dbb 3603 }
79072805
LW		 3604 }
3605 }
b08e453b 3606
a2a5de95
NC		 3607 if(del && rlen == tlen) {
3608 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3609 } else if(rlen > tlen) {
3610 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
b08e453b
RB		 3611 }
3612
9b877dbb
IH		 3613 if (grows)
3614 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 3615#ifdef PERL_MAD
3616 op_getmad(expr,o,'e');
3617 op_getmad(repl,o,'r');
3618#else
79072805
LW		 3619 op_free(expr);
3620 op_free(repl);
eb8433b7 3621#endif
79072805 3622
11343788 3623 return o;
79072805
LW		 3624}
3625
d67eb5f4
Z		 3626/*
3627=for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3628
3629Constructs, checks, and returns an op of any pattern matching type.
3630I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3631and, shifted up eight bits, the eight bits of C<op_private>.
3632
3633=cut
3634*/
3635
79072805 3636OP *
864dbfa3 3637Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 3638{
27da23d5 3639 dVAR;
79072805
LW		 3640 PMOP *pmop;
3641
e69777c1
GG		 3642 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3643
b7dc083c 3644 NewOp(1101, pmop, 1, PMOP);
eb160463 3645 pmop->op_type = (OPCODE)type;
22c35a8c 3646 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 3647 pmop->op_flags = (U8)flags;
3648 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 3649
3280af22 3650 if (PL_hints & HINT_RE_TAINT)
c737faaf 3651 pmop->op_pmflags |= PMf_RETAINT;
9de15fec 3652 if (PL_hints & HINT_LOCALE) {
c737faaf 3653 pmop->op_pmflags |= PMf_LOCALE;
9de15fec
KW		 3654 }
3655 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3656 pmop->op_pmflags |= RXf_PMf_UNICODE;
3657 }
c737faaf 3658
36477c24 3659
debc9467 3660#ifdef USE_ITHREADS
402d2eb1
NC		 3661 assert(SvPOK(PL_regex_pad[0]));
3662 if (SvCUR(PL_regex_pad[0])) {
3663 /* Pop off the "packed" IV from the end. */
3664 SV *const repointer_list = PL_regex_pad[0];
3665 const char *p = SvEND(repointer_list) - sizeof(IV);
3666 const IV offset = *((IV*)p);
3667
3668 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3669
3670 SvEND_set(repointer_list, p);
3671
110f3028 3672 pmop->op_pmoffset = offset;
14a49a24
NC		 3673 /* This slot should be free, so assert this: */
3674 assert(PL_regex_pad[offset] == &PL_sv_undef);
551405c4 3675 } else {
14a49a24 3676 SV * const repointer = &PL_sv_undef;
9a8b6709 3677 av_push(PL_regex_padav, repointer);
551405c4
AL		 3678 pmop->op_pmoffset = av_len(PL_regex_padav);
3679 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 3680 }
debc9467 3681#endif
1eb1540c 3682
463d09e6 3683 return CHECKOP(type, pmop);
79072805
LW		 3684}
3685
131b3ad0
DM		 3686/* Given some sort of match op o, and an expression expr containing a
3687 * pattern, either compile expr into a regex and attach it to o (if it's
3688 * constant), or convert expr into a runtime regcomp op sequence (if it's
3689 * not)
3690 *
3691 * isreg indicates that the pattern is part of a regex construct, eg
3692 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3693 * split "pattern", which aren't. In the former case, expr will be a list
3694 * if the pattern contains more than one term (eg /a$b/) or if it contains
3695 * a replacement, ie s/// or tr///.
3696 */
3697
79072805 3698OP *
131b3ad0 3699Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 3700{
27da23d5 3701 dVAR;
79072805
LW		 3702 PMOP *pm;
3703 LOGOP *rcop;
ce862d02 3704 I32 repl_has_vars = 0;
5f66b61c 3705 OP* repl = NULL;
131b3ad0
DM		 3706 bool reglist;
3707
7918f24d
NC		 3708 PERL_ARGS_ASSERT_PMRUNTIME;
3709
131b3ad0
DM		 3710 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3711 /* last element in list is the replacement; pop it */
3712 OP* kid;
3713 repl = cLISTOPx(expr)->op_last;
3714 kid = cLISTOPx(expr)->op_first;
3715 while (kid->op_sibling != repl)
3716 kid = kid->op_sibling;
5f66b61c 3717 kid->op_sibling = NULL;
131b3ad0
DM		 3718 cLISTOPx(expr)->op_last = kid;
3719 }
79072805 3720
131b3ad0
DM		 3721 if (isreg && expr->op_type == OP_LIST &&
3722 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3723 {
3724 /* convert single element list to element */
0bd48802 3725 OP* const oe = expr;
131b3ad0 3726 expr = cLISTOPx(oe)->op_first->op_sibling;
5f66b61c
AL		 3727 cLISTOPx(oe)->op_first->op_sibling = NULL;
3728 cLISTOPx(oe)->op_last = NULL;
131b3ad0
DM		 3729 op_free(oe);
3730 }
3731
3732 if (o->op_type == OP_TRANS) {
11343788 3733 return pmtrans(o, expr, repl);
131b3ad0
DM		 3734 }
3735
3736 reglist = isreg && expr->op_type == OP_LIST;
3737 if (reglist)
3738 op_null(expr);
79072805 3739
3280af22 3740 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3741 pm = (PMOP*)o;
79072805
LW		 3742
3743 if (expr->op_type == OP_CONST) {
b9ad30b4 3744 SV *pat = ((SVOP*)expr)->op_sv;
c737faaf 3745 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
5c144d81 3746
0ac6acae
AB		 3747 if (o->op_flags & OPf_SPECIAL)
3748 pm_flags |= RXf_SPLIT;
5c144d81 3749
b9ad30b4
NC		 3750 if (DO_UTF8(pat)) {
3751 assert (SvUTF8(pat));
3752 } else if (SvUTF8(pat)) {
3753 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3754 trapped in use 'bytes'? */
3755 /* Make a copy of the octet sequence, but without the flag on, as
3756 the compiler now honours the SvUTF8 flag on pat. */
3757 STRLEN len;
3758 const char *const p = SvPV(pat, len);
3759 pat = newSVpvn_flags(p, len, SVs_TEMP);
3760 }
0ac6acae 3761
3ab4a224 3762 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
c737faaf 3763
eb8433b7
NC		 3764#ifdef PERL_MAD
3765 op_getmad(expr,(OP*)pm,'e');
3766#else
79072805 3767 op_free(expr);
eb8433b7 3768#endif
79072805
LW		 3769 }
3770 else {
3280af22 3771 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3772 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3773 ? OP_REGCRESET
3774 : OP_REGCMAYBE),0,expr);
463ee0b2 3775
b7dc083c 3776 NewOp(1101, rcop, 1, LOGOP);
79072805 3777 rcop->op_type = OP_REGCOMP;
22c35a8c 3778 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3779 rcop->op_first = scalar(expr);
131b3ad0
DM		 3780 rcop->op_flags |= OPf_KIDS
3781 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3782 | (reglist ? OPf_STACKED : 0);
79072805 3783 rcop->op_private = 1;
11343788 3784 rcop->op_other = o;
131b3ad0
DM		 3785 if (reglist)
3786 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3787
b5c19bd7
DM		 3788 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3789 PL_cv_has_eval = 1;
79072805
LW		 3790
3791 /* establish postfix order */
3280af22 3792 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3793 LINKLIST(expr);
3794 rcop->op_next = expr;
3795 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3796 }
3797 else {
3798 rcop->op_next = LINKLIST(expr);
3799 expr->op_next = (OP*)rcop;
3800 }
79072805 3801
11343788 3802 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3803 }
3804
3805 if (repl) {
748a9306 3806 OP *curop;
0244c3a4 3807 if (pm->op_pmflags & PMf_EVAL) {
6136c704 3808 curop = NULL;
670a9cb2
DM		 3809 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3810 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
0244c3a4 3811 }
748a9306
LW		 3812 else if (repl->op_type == OP_CONST)
3813 curop = repl;
79072805 3814 else {
c445ea15 3815 OP *lastop = NULL;
79072805 3816 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
e80b829c 3817 if (curop->op_type == OP_SCOPE
10250113 3818 || curop->op_type == OP_LEAVE
e80b829c 3819 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
79072805 3820 if (curop->op_type == OP_GV) {
6136c704 3821 GV * const gv = cGVOPx_gv(curop);
ce862d02 3822 repl_has_vars = 1;
f702bf4a 3823 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 3824 break;
3825 }
3826 else if (curop->op_type == OP_RV2CV)
3827 break;
3828 else if (curop->op_type == OP_RV2SV ||
3829 curop->op_type == OP_RV2AV ||
3830 curop->op_type == OP_RV2HV ||
3831 curop->op_type == OP_RV2GV) {
3832 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3833 break;
3834 }
748a9306
LW		 3835 else if (curop->op_type == OP_PADSV ||
3836 curop->op_type == OP_PADAV ||
3837 curop->op_type == OP_PADHV ||
e80b829c
RGS		 3838 curop->op_type == OP_PADANY)
3839 {
ce862d02 3840 repl_has_vars = 1;
748a9306 3841 }
1167e5da 3842 else if (curop->op_type == OP_PUSHRE)
6f207bd3 3843 NOOP; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3844 else
3845 break;
3846 }
3847 lastop = curop;
3848 }
748a9306 3849 }
ce862d02 3850 if (curop == repl
e80b829c
RGS		 3851 && !(repl_has_vars
3852 && (!PM_GETRE(pm)
07bc277f 3853 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3be69782 3854 {
748a9306 3855 pm->op_pmflags |= PMf_CONST; /* const for long enough */
11343788 3856 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3857 }
3858 else {
aaa362c4 3859 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02 3860 pm->op_pmflags |= PMf_MAYBE_CONST;
ce862d02 3861 }
b7dc083c 3862 NewOp(1101, rcop, 1, LOGOP);
748a9306 3863 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3864 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3865 rcop->op_first = scalar(repl);
3866 rcop->op_flags |= OPf_KIDS;
3867 rcop->op_private = 1;
11343788 3868 rcop->op_other = o;
748a9306
LW		 3869
3870 /* establish postfix order */
3871 rcop->op_next = LINKLIST(repl);
3872 repl->op_next = (OP*)rcop;
3873
20e98b0f 3874 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
29f2e912
NC		 3875 assert(!(pm->op_pmflags & PMf_ONCE));
3876 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
748a9306 3877 rcop->op_next = 0;
79072805
LW		 3878 }
3879 }
3880
3881 return (OP*)pm;
3882}
3883
d67eb5f4
Z		 3884/*
3885=for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
3886
3887Constructs, checks, and returns an op of any type that involves an
3888embedded SV. I<type> is the opcode. I<flags> gives the eight bits
3889of C<op_flags>. I<sv> gives the SV to embed in the op; this function
3890takes ownership of one reference to it.
3891
3892=cut
3893*/
3894
79072805 3895OP *
864dbfa3 3896Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 3897{
27da23d5 3898 dVAR;
79072805 3899 SVOP *svop;
7918f24d
NC		 3900
3901 PERL_ARGS_ASSERT_NEWSVOP;
3902
e69777c1
GG		 3903 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3904 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3905 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3906
b7dc083c 3907 NewOp(1101, svop, 1, SVOP);
eb160463 3908 svop->op_type = (OPCODE)type;
22c35a8c 3909 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3910 svop->op_sv = sv;
3911 svop->op_next = (OP*)svop;
eb160463 3912 svop->op_flags = (U8)flags;
22c35a8c 3913 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3914 scalar((OP*)svop);
22c35a8c 3915 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3916 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3917 return CHECKOP(type, svop);
79072805
LW		 3918}
3919
392d04bb 3920#ifdef USE_ITHREADS
d67eb5f4
Z		 3921
3922/*
3923=for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
3924
3925Constructs, checks, and returns an op of any type that involves a
3926reference to a pad element. I<type> is the opcode. I<flags> gives the
3927eight bits of C<op_flags>. A pad slot is automatically allocated, and
3928is populated with I<sv>; this function takes ownership of one reference
3929to it.
3930
3931This function only exists if Perl has been compiled to use ithreads.
3932
3933=cut
3934*/
3935
79072805 3936OP *
350de78d
GS		 3937Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3938{
27da23d5 3939 dVAR;
350de78d 3940 PADOP *padop;
7918f24d
NC		 3941
3942 PERL_ARGS_ASSERT_NEWPADOP;
3943
e69777c1
GG		 3944 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3945 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3946 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3947
350de78d 3948 NewOp(1101, padop, 1, PADOP);
eb160463 3949 padop->op_type = (OPCODE)type;
350de78d
GS		 3950 padop->op_ppaddr = PL_ppaddr[type];
3951 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 3952 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3953 PAD_SETSV(padop->op_padix, sv);
58182927
NC		 3954 assert(sv);
3955 SvPADTMP_on(sv);
350de78d 3956 padop->op_next = (OP*)padop;
eb160463 3957 padop->op_flags = (U8)flags;
350de78d
GS		 3958 if (PL_opargs[type] & OA_RETSCALAR)
3959 scalar((OP*)padop);
3960 if (PL_opargs[type] & OA_TARGET)
3961 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3962 return CHECKOP(type, padop);
3963}
d67eb5f4
Z		 3964
3965#endif /* !USE_ITHREADS */
3966
3967/*
3968=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
3969
3970Constructs, checks, and returns an op of any type that involves an
3971embedded reference to a GV. I<type> is the opcode. I<flags> gives the
3972eight bits of C<op_flags>. I<gv> identifies the GV that the op should
3973reference; calling this function does not transfer ownership of any
3974reference to it.
3975
3976=cut
3977*/
350de78d
GS		 3978
3979OP *
864dbfa3 3980Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3981{
27da23d5 3982 dVAR;
7918f24d
NC		 3983
3984 PERL_ARGS_ASSERT_NEWGVOP;
3985
350de78d 3986#ifdef USE_ITHREADS
58182927 3987 GvIN_PAD_on(gv);
ff8997d7 3988 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 3989#else
ff8997d7 3990 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 3991#endif
79072805
LW		 3992}
3993
d67eb5f4
Z		 3994/*
3995=for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
3996
3997Constructs, checks, and returns an op of any type that involves an
3998embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
3999the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4000must have been allocated using L</PerlMemShared_malloc>; the memory will
4001be freed when the op is destroyed.
4002
4003=cut
4004*/
4005
79072805 4006OP *
864dbfa3 4007Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 4008{
27da23d5 4009 dVAR;
79072805 4010 PVOP *pvop;
e69777c1
GG		 4011
4012 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4013 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4014
b7dc083c 4015 NewOp(1101, pvop, 1, PVOP);
eb160463 4016 pvop->op_type = (OPCODE)type;
22c35a8c 4017 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 4018 pvop->op_pv = pv;
4019 pvop->op_next = (OP*)pvop;
eb160463 4020 pvop->op_flags = (U8)flags;
22c35a8c 4021 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 4022 scalar((OP*)pvop);
22c35a8c 4023 if (PL_opargs[type] & OA_TARGET)
ed6116ce 4024 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 4025 return CHECKOP(type, pvop);
79072805
LW		 4026}
4027
eb8433b7
NC		 4028#ifdef PERL_MAD
4029OP*
4030#else
79072805 4031void
eb8433b7 4032#endif
864dbfa3 4033Perl_package(pTHX_ OP *o)
79072805 4034{
97aff369 4035 dVAR;
bf070237 4036 SV *const sv = cSVOPo->op_sv;
eb8433b7
NC		 4037#ifdef PERL_MAD
4038 OP *pegop;
4039#endif
79072805 4040
7918f24d
NC		 4041 PERL_ARGS_ASSERT_PACKAGE;
4042
3280af22
NIS		 4043 save_hptr(&PL_curstash);
4044 save_item(PL_curstname);
de11ba31 4045
bf070237 4046 PL_curstash = gv_stashsv(sv, GV_ADD);
e1a479c5 4047
bf070237 4048 sv_setsv(PL_curstname, sv);
de11ba31 4049
7ad382f4 4050 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 4051 PL_parser->copline = NOLINE;
4052 PL_parser->expect = XSTATE;
eb8433b7
NC		 4053
4054#ifndef PERL_MAD
4055 op_free(o);
4056#else
4057 if (!PL_madskills) {
4058 op_free(o);
1d866c12 4059 return NULL;
eb8433b7
NC		 4060 }
4061
4062 pegop = newOP(OP_NULL,0);
4063 op_getmad(o,pegop,'P');
4064 return pegop;
4065#endif
79072805
LW		 4066}
4067
6fa4d285
DG		 4068void
4069Perl_package_version( pTHX_ OP *v )
4070{
4071 dVAR;
458818ec 4072 U32 savehints = PL_hints;
6fa4d285 4073 PERL_ARGS_ASSERT_PACKAGE_VERSION;
458818ec 4074 PL_hints &= ~HINT_STRICT_VARS;
e92f586b 4075 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
458818ec 4076 PL_hints = savehints;
6fa4d285
DG		 4077 op_free(v);
4078}
4079
eb8433b7
NC		 4080#ifdef PERL_MAD
4081OP*
4082#else
85e6fe83 4083void
eb8433b7 4084#endif
88d95a4d 4085Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 4086{
97aff369 4087 dVAR;
a0d0e21e 4088 OP *pack;
a0d0e21e 4089 OP *imop;
b1cb66bf 4090 OP *veop;
eb8433b7
NC		 4091#ifdef PERL_MAD
4092 OP *pegop = newOP(OP_NULL,0);
4093#endif
85e6fe83 4094
7918f24d
NC		 4095 PERL_ARGS_ASSERT_UTILIZE;
4096
88d95a4d 4097 if (idop->op_type != OP_CONST)
cea2e8a9 4098 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 4099
eb8433b7
NC		 4100 if (PL_madskills)
4101 op_getmad(idop,pegop,'U');
4102
5f66b61c 4103 veop = NULL;
b1cb66bf 4104
aec46f14 4105 if (version) {
551405c4 4106 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 4107
eb8433b7
NC		 4108 if (PL_madskills)
4109 op_getmad(version,pegop,'V');
aec46f14 4110 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 4111 arg = version;
4112 }
4113 else {
4114 OP *pack;
0f79a09d 4115 SV *meth;
b1cb66bf 4116
44dcb63b 4117 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
fe13d51d 4118 Perl_croak(aTHX_ "Version number must be a constant number");
b1cb66bf 4119
88d95a4d
JH		 4120 /* Make copy of idop so we don't free it twice */
4121 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 4122
4123 /* Fake up a method call to VERSION */
18916d0d 4124 meth = newSVpvs_share("VERSION");
b1cb66bf 4125 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4126 append_elem(OP_LIST,
0f79a09d
GS		 4127 prepend_elem(OP_LIST, pack, list(version)),
4128 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 4129 }
4130 }
aeea060c 4131
a0d0e21e 4132 /* Fake up an import/unimport */
eb8433b7
NC		 4133 if (arg && arg->op_type == OP_STUB) {
4134 if (PL_madskills)
4135 op_getmad(arg,pegop,'S');
4633a7c4 4136 imop = arg; /* no import on explicit () */
eb8433b7 4137 }
88d95a4d 4138 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 4139 imop = NULL; /* use 5.0; */
468aa647
RGS		 4140 if (!aver)
4141 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 4142 }
4633a7c4 4143 else {
0f79a09d
GS		 4144 SV *meth;
4145
eb8433b7
NC		 4146 if (PL_madskills)
4147 op_getmad(arg,pegop,'A');
4148
88d95a4d
JH		 4149 /* Make copy of idop so we don't free it twice */
4150 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 4151
4152 /* Fake up a method call to import/unimport */
427d62a4 4153 meth = aver
18916d0d 4154 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 4155 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 4156 append_elem(OP_LIST,
4157 prepend_elem(OP_LIST, pack, list(arg)),
4158 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 4159 }
4160
a0d0e21e 4161 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 4162 newATTRSUB(floor,
18916d0d 4163 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL		 4164 NULL,
4165 NULL,
a0d0e21e 4166 append_elem(OP_LINESEQ,
b1cb66bf 4167 append_elem(OP_LINESEQ,
bd61b366
SS		 4168 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4169 newSTATEOP(0, NULL, veop)),
4170 newSTATEOP(0, NULL, imop) ));
85e6fe83 4171
70f5e4ed
JH		 4172 /* The "did you use incorrect case?" warning used to be here.
4173 * The problem is that on case-insensitive filesystems one
4174 * might get false positives for "use" (and "require"):
4175 * "use Strict" or "require CARP" will work. This causes
4176 * portability problems for the script: in case-strict
4177 * filesystems the script will stop working.
4178 *
4179 * The "incorrect case" warning checked whether "use Foo"
4180 * imported "Foo" to your namespace, but that is wrong, too:
4181 * there is no requirement nor promise in the language that
4182 * a Foo.pm should or would contain anything in package "Foo".
4183 *
4184 * There is very little Configure-wise that can be done, either:
4185 * the case-sensitivity of the build filesystem of Perl does not
4186 * help in guessing the case-sensitivity of the runtime environment.
4187 */
18fc9488 4188
c305c6a0 4189 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 4190 PL_parser->copline = NOLINE;
4191 PL_parser->expect = XSTATE;
8ec8fbef 4192 PL_cop_seqmax++; /* Purely for B::*'s benefit */
eb8433b7
NC		 4193
4194#ifdef PERL_MAD
4195 if (!PL_madskills) {
4196 /* FIXME - don't allocate pegop if !PL_madskills */
4197 op_free(pegop);
1d866c12 4198 return NULL;
eb8433b7
NC		 4199 }
4200 return pegop;
4201#endif
85e6fe83
LW		 4202}
4203
7d3fb230 4204/*
ccfc67b7
JH		 4205=head1 Embedding Functions
4206
7d3fb230
BS		 4207=for apidoc load_module
4208
4209Loads the module whose name is pointed to by the string part of name.
4210Note that the actual module name, not its filename, should be given.
4211Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4212PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4213(or 0 for no flags). ver, if specified, provides version semantics
4214similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4215arguments can be used to specify arguments to the module's import()
76f108ac
JD		 4216method, similar to C<use Foo::Bar VERSION LIST>. They must be
4217terminated with a final NULL pointer. Note that this list can only
4218be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4219Otherwise at least a single NULL pointer to designate the default
4220import list is required.
7d3fb230
BS		 4221
4222=cut */
4223
e4783991
GS		 4224void
4225Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4226{
4227 va_list args;
7918f24d
NC		 4228
4229 PERL_ARGS_ASSERT_LOAD_MODULE;
4230
e4783991
GS		 4231 va_start(args, ver);
4232 vload_module(flags, name, ver, &args);
4233 va_end(args);
4234}
4235
4236#ifdef PERL_IMPLICIT_CONTEXT
4237void
4238Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4239{
4240 dTHX;
4241 va_list args;
7918f24d 4242 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
e4783991
GS		 4243 va_start(args, ver);
4244 vload_module(flags, name, ver, &args);
4245 va_end(args);
4246}
4247#endif
4248
4249void
4250Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4251{
97aff369 4252 dVAR;
551405c4 4253 OP *veop, *imop;
551405c4 4254 OP * const modname = newSVOP(OP_CONST, 0, name);
7918f24d
NC		 4255
4256 PERL_ARGS_ASSERT_VLOAD_MODULE;
4257
e4783991
GS		 4258 modname->op_private |= OPpCONST_BARE;
4259 if (ver) {
4260 veop = newSVOP(OP_CONST, 0, ver);
4261 }
4262 else
5f66b61c 4263 veop = NULL;
e4783991
GS		 4264 if (flags & PERL_LOADMOD_NOIMPORT) {
4265 imop = sawparens(newNULLLIST());
4266 }
4267 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4268 imop = va_arg(*args, OP*);
4269 }
4270 else {
4271 SV *sv;
5f66b61c 4272 imop = NULL;
e4783991
GS		 4273 sv = va_arg(*args, SV*);
4274 while (sv) {
4275 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4276 sv = va_arg(*args, SV*);
4277 }
4278 }
81885997 4279
53a7735b
DM		 4280 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4281 * that it has a PL_parser to play with while doing that, and also
4282 * that it doesn't mess with any existing parser, by creating a tmp
4283 * new parser with lex_start(). This won't actually be used for much,
4284 * since pp_require() will create another parser for the real work. */
4285
4286 ENTER;
4287 SAVEVPTR(PL_curcop);
5486870f 4288 lex_start(NULL, NULL, FALSE);
53a7735b
DM		 4289 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4290 veop, modname, imop);
4291 LEAVE;
e4783991
GS		 4292}
4293
79072805 4294OP *
850e8516 4295Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 4296{
97aff369 4297 dVAR;
78ca652e 4298 OP *doop;
a0714e2c 4299 GV *gv = NULL;
78ca652e 4300
7918f24d
NC		 4301 PERL_ARGS_ASSERT_DOFILE;
4302
850e8516 4303 if (!force_builtin) {
fafc274c 4304 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
850e8516 4305 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 4306 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
a0714e2c 4307 gv = gvp ? *gvp : NULL;
850e8516
RGS		 4308 }
4309 }
78ca652e 4310
b9f751c0 4311 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 4312 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4313 append_elem(OP_LIST, term,
4314 scalar(newUNOP(OP_RV2CV, 0,
d4c19fe8 4315 newGVOP(OP_GV, 0, gv))))));
78ca652e
GS		 4316 }
4317 else {
4318 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4319 }
4320 return doop;
4321}
4322
d67eb5f4
Z		 4323/*
4324=head1 Optree construction
4325
4326=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4327
4328Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4329gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4330be set automatically, and, shifted up eight bits, the eight bits of
4331C<op_private>, except that the bit with value 1 or 2 is automatically
4332set as required. I<listval> and I<subscript> supply the parameters of
4333the slice; they are consumed by this function and become part of the
4334constructed op tree.
4335
4336=cut
4337*/
4338
78ca652e 4339OP *
864dbfa3 4340Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 4341{
4342 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 4343 list(force_list(subscript)),
4344 list(force_list(listval)) );
79072805
LW		 4345}
4346
76e3520e 4347STATIC I32
504618e9 4348S_is_list_assignment(pTHX_ register const OP *o)
79072805 4349{
1496a290
AL		 4350 unsigned type;
4351 U8 flags;
4352
11343788 4353 if (!o)
79072805
LW		 4354 return TRUE;
4355
1496a290 4356 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
11343788 4357 o = cUNOPo->op_first;
79072805 4358
1496a290
AL		 4359 flags = o->op_flags;
4360 type = o->op_type;
4361 if (type == OP_COND_EXPR) {
504618e9
AL		 4362 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4363 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 4364
4365 if (t && f)
4366 return TRUE;
4367 if (t || f)
4368 yyerror("Assignment to both a list and a scalar");
4369 return FALSE;
4370 }
4371
1496a290
AL		 4372 if (type == OP_LIST &&
4373 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
95f0a2f1
SB		 4374 o->op_private & OPpLVAL_INTRO)
4375 return FALSE;
4376
1496a290
AL		 4377 if (type == OP_LIST || flags & OPf_PARENS ||
4378 type == OP_RV2AV || type == OP_RV2HV ||
4379 type == OP_ASLICE || type == OP_HSLICE)
79072805
LW		 4380 return TRUE;
4381
1496a290 4382 if (type == OP_PADAV || type == OP_PADHV)
93a17b20
LW		 4383 return TRUE;
4384
1496a290 4385 if (type == OP_RV2SV)
79072805
LW		 4386 return FALSE;
4387
4388 return FALSE;
4389}
4390
d67eb5f4
Z		 4391/*
4392=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4393
4394Constructs, checks, and returns an assignment op. I<left> and I<right>
4395supply the parameters of the assignment; they are consumed by this
4396function and become part of the constructed op tree.
4397
4398If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4399a suitable conditional optree is constructed. If I<optype> is the opcode
4400of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4401performs the binary operation and assigns the result to the left argument.
4402Either way, if I<optype> is non-zero then I<flags> has no effect.
4403
4404If I<optype> is zero, then a plain scalar or list assignment is
4405constructed. Which type of assignment it is is automatically determined.
4406I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4407will be set automatically, and, shifted up eight bits, the eight bits
4408of C<op_private>, except that the bit with value 1 or 2 is automatically
4409set as required.
4410
4411=cut
4412*/
4413
79072805 4414OP *
864dbfa3 4415Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 4416{
97aff369 4417 dVAR;
11343788 4418 OP *o;
79072805 4419
a0d0e21e 4420 if (optype) {
c963b151 4421 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW		 4422 return newLOGOP(optype, 0,
4423 mod(scalar(left), optype),
4424 newUNOP(OP_SASSIGN, 0, scalar(right)));
4425 }
4426 else {
4427 return newBINOP(optype, OPf_STACKED,
4428 mod(scalar(left), optype), scalar(right));
4429 }
4430 }
4431
504618e9 4432 if (is_list_assignment(left)) {
6dbe9451
NC		 4433 static const char no_list_state[] = "Initialization of state variables"
4434 " in list context currently forbidden";
10c8fecd 4435 OP *curop;
fafafbaf 4436 bool maybe_common_vars = TRUE;
10c8fecd 4437
3280af22 4438 PL_modcount = 0;
dbfe47cf
RD		 4439 /* Grandfathering $[ assignment here. Bletch.*/
4440 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
fe5bfecd 4441 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
463ee0b2 4442 left = mod(left, OP_AASSIGN);
3280af22
NIS		 4443 if (PL_eval_start)
4444 PL_eval_start = 0;
dbfe47cf 4445 else if (left->op_type == OP_CONST) {
f175a6ef 4446 deprecate("assignment to $[");
eb8433b7 4447 /* FIXME for MAD */
dbfe47cf
RD		 4448 /* Result of assignment is always 1 (or we'd be dead already) */
4449 return newSVOP(OP_CONST, 0, newSViv(1));
a0d0e21e 4450 }
10c8fecd
GS		 4451 curop = list(force_list(left));
4452 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 4453 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4 4454
fafafbaf
RD		 4455 if ((left->op_type == OP_LIST
4456 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4457 {
4458 OP* lop = ((LISTOP*)left)->op_first;
4459 maybe_common_vars = FALSE;
4460 while (lop) {
4461 if (lop->op_type == OP_PADSV ||
4462 lop->op_type == OP_PADAV ||
4463 lop->op_type == OP_PADHV ||
4464 lop->op_type == OP_PADANY) {
4465 if (!(lop->op_private & OPpLVAL_INTRO))
4466 maybe_common_vars = TRUE;
4467
4468 if (lop->op_private & OPpPAD_STATE) {
4469 if (left->op_private & OPpLVAL_INTRO) {
4470 /* Each variable in state($a, $b, $c) = ... */
4471 }
4472 else {
4473 /* Each state variable in
4474 (state $a, my $b, our $c, $d, undef) = ... */
4475 }
4476 yyerror(no_list_state);
4477 } else {
4478 /* Each my variable in
4479 (state $a, my $b, our $c, $d, undef) = ... */
4480 }
4481 } else if (lop->op_type == OP_UNDEF ||
4482 lop->op_type == OP_PUSHMARK) {
4483 /* undef may be interesting in
4484 (state $a, undef, state $c) */
4485 } else {
4486 /* Other ops in the list. */
4487 maybe_common_vars = TRUE;
4488 }
4489 lop = lop->op_sibling;
4490 }
4491 }
4492 else if ((left->op_private & OPpLVAL_INTRO)
4493 && ( left->op_type == OP_PADSV
4494 || left->op_type == OP_PADAV
4495 || left->op_type == OP_PADHV
4496 || left->op_type == OP_PADANY))
4497 {
0f907b96 4498 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
fafafbaf
RD		 4499 if (left->op_private & OPpPAD_STATE) {
4500 /* All single variable list context state assignments, hence
4501 state ($a) = ...
4502 (state $a) = ...
4503 state @a = ...
4504 state (@a) = ...
4505 (state @a) = ...
4506 state %a = ...
4507 state (%a) = ...
4508 (state %a) = ...
4509 */
4510 yyerror(no_list_state);
4511 }
4512 }
4513
dd2155a4
DM		 4514 /* PL_generation sorcery:
4515 * an assignment like ($a,$b) = ($c,$d) is easier than
4516 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4517 * To detect whether there are common vars, the global var
4518 * PL_generation is incremented for each assign op we compile.
4519 * Then, while compiling the assign op, we run through all the
4520 * variables on both sides of the assignment, setting a spare slot
4521 * in each of them to PL_generation. If any of them already have
4522 * that value, we know we've got commonality. We could use a
4523 * single bit marker, but then we'd have to make 2 passes, first
4524 * to clear the flag, then to test and set it. To find somewhere
931b58fb 4525 * to store these values, evil chicanery is done with SvUVX().
dd2155a4
DM		 4526 */
4527
fafafbaf 4528 if (maybe_common_vars) {
11343788 4529 OP *lastop = o;
3280af22 4530 PL_generation++;
11343788 4531 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 4532 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 4533 if (curop->op_type == OP_GV) {
638eceb6 4534 GV *gv = cGVOPx_gv(curop);
169d2d72
NC		 4535 if (gv == PL_defgv
4536 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
79072805 4537 break;
169d2d72 4538 GvASSIGN_GENERATION_set(gv, PL_generation);
79072805 4539 }
748a9306
LW		 4540 else if (curop->op_type == OP_PADSV ||
4541 curop->op_type == OP_PADAV ||
4542 curop->op_type == OP_PADHV ||
dd2155a4
DM		 4543 curop->op_type == OP_PADANY)
4544 {
4545 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 4546 == (STRLEN)PL_generation)
748a9306 4547 break;
b162af07 4548 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
dd2155a4 4549
748a9306 4550 }
79072805
LW		 4551 else if (curop->op_type == OP_RV2CV)
4552 break;
4553 else if (curop->op_type == OP_RV2SV ||
4554 curop->op_type == OP_RV2AV ||
4555 curop->op_type == OP_RV2HV ||
4556 curop->op_type == OP_RV2GV) {
4557 if (lastop->op_type != OP_GV) /* funny deref? */
4558 break;
4559 }
1167e5da 4560 else if (curop->op_type == OP_PUSHRE) {
b3f5893f 4561#ifdef USE_ITHREADS
20e98b0f 4562 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
159b6efe 4563 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
169d2d72
NC		 4564 if (gv == PL_defgv
4565 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
1167e5da 4566 break;
169d2d72 4567 GvASSIGN_GENERATION_set(gv, PL_generation);
20e98b0f
NC		 4568 }
4569#else
4570 GV *const gv
4571 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4572 if (gv) {
4573 if (gv == PL_defgv
4574 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4575 break;
169d2d72 4576 GvASSIGN_GENERATION_set(gv, PL_generation);
b2ffa427 4577 }
20e98b0f 4578#endif
1167e5da 4579 }
79072805
LW		 4580 else
4581 break;
4582 }
4583 lastop = curop;
4584 }
11343788 4585 if (curop != o)
10c8fecd 4586 o->op_private |= OPpASSIGN_COMMON;
461824dc 4587 }
9fdc7570 4588
e9cc17ba 4589 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
1496a290
AL		 4590 OP* tmpop = ((LISTOP*)right)->op_first;
4591 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
551405c4 4592 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 4593 if (left->op_type == OP_RV2AV &&
4594 !(left->op_private & OPpLVAL_INTRO) &&
11343788 4595 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 4596 {
4597 tmpop = ((UNOP*)left)->op_first;
20e98b0f
NC		 4598 if (tmpop->op_type == OP_GV
4599#ifdef USE_ITHREADS
4600 && !pm->op_pmreplrootu.op_pmtargetoff
4601#else
4602 && !pm->op_pmreplrootu.op_pmtargetgv
4603#endif
4604 ) {
971a9dd3 4605#ifdef USE_ITHREADS
20e98b0f
NC		 4606 pm->op_pmreplrootu.op_pmtargetoff
4607 = cPADOPx(tmpop)->op_padix;
971a9dd3
GS		 4608 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4609#else
20e98b0f 4610 pm->op_pmreplrootu.op_pmtargetgv
159b6efe 4611 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
a0714e2c 4612 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 4613#endif
c07a80fd 4614 pm->op_pmflags |= PMf_ONCE;
11343788 4615 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 4616 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 4617 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 4618 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 4619 op_free(o); /* blow off assign */
54310121 4620 right->op_flags &= ~OPf_WANT;
a5f75d66 4621 /* "I don't know and I don't care." */
c07a80fd 4622 return right;
4623 }
4624 }
4625 else {
e6438c1a 4626 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 4627 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4628 {
4629 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
b8de32d5 4630 if (SvIOK(sv) && SvIVX(sv) == 0)
3280af22 4631 sv_setiv(sv, PL_modcount+1);
c07a80fd 4632 }
4633 }
4634 }
4635 }
11343788 4636 return o;
79072805
LW		 4637 }
4638 if (!right)
4639 right = newOP(OP_UNDEF, 0);
4640 if (right->op_type == OP_READLINE) {
4641 right->op_flags |= OPf_STACKED;
463ee0b2 4642 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 4643 }
a0d0e21e 4644 else {
3280af22 4645 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 4646 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 4647 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 4648 if (PL_eval_start)
4649 PL_eval_start = 0;
748a9306 4650 else {
27aaedc1 4651 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
55b67815 4652 deprecate("assignment to $[");
27aaedc1
GG		 4653 op_free(o);
4654 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4655 o->op_private |= OPpCONST_ARYBASE;
4656 }
a0d0e21e
LW		 4657 }
4658 }
11343788 4659 return o;
79072805
LW		 4660}
4661
d67eb5f4
Z		 4662/*
4663=for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4664
4665Constructs a state op (COP). The state op is normally a C<nextstate> op,
4666but will be a C<dbstate> op if debugging is enabled for currently-compiled
4667code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4668If I<label> is non-null, it supplies the name of a label to attach to
4669the state op; this function takes ownership of the memory pointed at by
4670I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4671for the state op.
4672
4673If I<o> is null, the state op is returned. Otherwise the state op is
4674combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4675is consumed by this function and becomes part of the returned op tree.
4676
4677=cut
4678*/
4679
79072805 4680OP *
864dbfa3 4681Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 4682{
27da23d5 4683 dVAR;
e1ec3a88 4684 const U32 seq = intro_my();
79072805
LW		 4685 register COP *cop;
4686
b7dc083c 4687 NewOp(1101, cop, 1, COP);
57843af0 4688 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 4689 cop->op_type = OP_DBSTATE;
22c35a8c 4690 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 4691 }
4692 else {
4693 cop->op_type = OP_NEXTSTATE;
22c35a8c 4694 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 4695 }
eb160463 4696 cop->op_flags = (U8)flags;
623e6609 4697 CopHINTS_set(cop, PL_hints);
ff0cee69 4698#ifdef NATIVE_HINTS
4699 cop->op_private |= NATIVE_HINTS;
4700#endif
623e6609 4701 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 4702 cop->op_next = (OP*)cop;
4703
bbce6d69 4704 cop->cop_seq = seq;
7b0bddfa 4705 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
c28fe1ec
NC		 4706 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4707 */
72dc9ed5 4708 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
c28fe1ec
NC		 4709 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4710 if (cop->cop_hints_hash) {
cbb1fbea 4711 HINTS_REFCNT_LOCK;
c28fe1ec 4712 cop->cop_hints_hash->refcounted_he_refcnt++;
cbb1fbea 4713 HINTS_REFCNT_UNLOCK;
b3ca2e83 4714 }
dca6062a 4715 if (label) {
a77ac40c 4716 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
dca6062a
NC		 4717
4718 PL_hints |= HINT_BLOCK_SCOPE;
4719 /* It seems that we need to defer freeing this pointer, as other parts
4720 of the grammar end up wanting to copy it after this op has been
4721 created. */
4722 SAVEFREEPV(label);
dca6062a 4723 }
79072805 4724
53a7735b 4725 if (PL_parser && PL_parser->copline == NOLINE)
57843af0 4726 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 4727 else {
53a7735b
DM		 4728 CopLINE_set(cop, PL_parser->copline);
4729 if (PL_parser)
4730 PL_parser->copline = NOLINE;
79072805 4731 }
57843af0 4732#ifdef USE_ITHREADS
f4dd75d9 4733 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 4734#else
f4dd75d9 4735 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 4736#endif
11faa288 4737 CopSTASH_set(cop, PL_curstash);
79072805 4738
65269a95
TB		 4739 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4740 /* this line can have a breakpoint - store the cop in IV */
80a702cd
RGS		 4741 AV *av = CopFILEAVx(PL_curcop);
4742 if (av) {
4743 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4744 if (svp && *svp != &PL_sv_undef ) {
4745 (void)SvIOK_on(*svp);
4746 SvIV_set(*svp, PTR2IV(cop));
4747 }
1eb1540c 4748 }
93a17b20
LW		 4749 }
4750
f6f3a1fe
RGS		 4751 if (flags & OPf_SPECIAL)
4752 op_null((OP*)cop);
722969e2 4753 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 4754}
4755
d67eb5f4
Z		 4756/*
4757=for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4758
4759Constructs, checks, and returns a logical (flow control) op. I<type>
4760is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4761that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4762the eight bits of C<op_private>, except that the bit with value 1 is
4763automatically set. I<first> supplies the expression controlling the
4764flow, and I<other> supplies the side (alternate) chain of ops; they are
4765consumed by this function and become part of the constructed op tree.
4766
4767=cut
4768*/
bbce6d69 4769
79072805 4770OP *
864dbfa3 4771Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 4772{
27da23d5 4773 dVAR;
7918f24d
NC		 4774
4775 PERL_ARGS_ASSERT_NEWLOGOP;
4776
883ffac3
CS		 4777 return new_logop(type, flags, &first, &other);
4778}
4779
3bd495df 4780STATIC OP *
71c4dbc3
VP		 4781S_search_const(pTHX_ OP *o)
4782{
4783 PERL_ARGS_ASSERT_SEARCH_CONST;
4784
4785 switch (o->op_type) {
4786 case OP_CONST:
4787 return o;
4788 case OP_NULL:
4789 if (o->op_flags & OPf_KIDS)
4790 return search_const(cUNOPo->op_first);
4791 break;
4792 case OP_LEAVE:
4793 case OP_SCOPE:
4794 case OP_LINESEQ:
4795 {
4796 OP *kid;
4797 if (!(o->op_flags & OPf_KIDS))
4798 return NULL;
4799 kid = cLISTOPo->op_first;
4800 do {
4801 switch (kid->op_type) {
4802 case OP_ENTER:
4803 case OP_NULL:
4804 case OP_NEXTSTATE:
4805 kid = kid->op_sibling;
4806 break;
4807 default:
4808 if (kid != cLISTOPo->op_last)
4809 return NULL;
4810 goto last;
4811 }
4812 } while (kid);
4813 if (!kid)
4814 kid = cLISTOPo->op_last;
4815last:
4816 return search_const(kid);
4817 }
4818 }
4819
4820 return NULL;
4821}
4822
4823STATIC OP *
cea2e8a9 4824S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 4825{
27da23d5 4826 dVAR;
79072805 4827 LOGOP *logop;
11343788 4828 OP *o;
71c4dbc3
VP		 4829 OP *first;
4830 OP *other;
4831 OP *cstop = NULL;
edbe35ea 4832 int prepend_not = 0;
79072805 4833
7918f24d
NC		 4834 PERL_ARGS_ASSERT_NEW_LOGOP;
4835
71c4dbc3
VP		 4836 first = *firstp;
4837 other = *otherp;
4838
a0d0e21e
LW		 4839 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4840 return newBINOP(type, flags, scalar(first), scalar(other));
4841
e69777c1
GG		 4842 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4843
8990e307 4844 scalarboolean(first);
edbe35ea 4845 /* optimize AND and OR ops that have NOTs as children */
68726e16 4846 if (first->op_type == OP_NOT
b6214b80 4847 && (first->op_flags & OPf_KIDS)
edbe35ea
VP		 4848 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4849 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
b6214b80 4850 && !PL_madskills) {
79072805
LW		 4851 if (type == OP_AND || type == OP_OR) {
4852 if (type == OP_AND)
4853 type = OP_OR;
4854 else
4855 type = OP_AND;
07f3cdf5 4856 op_null(first);
edbe35ea 4857 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
07f3cdf5 4858 op_null(other);
edbe35ea
VP		 4859 prepend_not = 1; /* prepend a NOT op later */
4860 }
79072805
LW		 4861 }
4862 }
71c4dbc3
VP		 4863 /* search for a constant op that could let us fold the test */
4864 if ((cstop = search_const(first))) {
4865 if (cstop->op_private & OPpCONST_STRICT)
4866 no_bareword_allowed(cstop);
a2a5de95
NC		 4867 else if ((cstop->op_private & OPpCONST_BARE))
4868 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
71c4dbc3
VP		 4869 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4870 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4871 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5f66b61c 4872 *firstp = NULL;
d6fee5c7
DM		 4873 if (other->op_type == OP_CONST)
4874 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4875 if (PL_madskills) {
4876 OP *newop = newUNOP(OP_NULL, 0, other);
4877 op_getmad(first, newop, '1');
4878 newop->op_targ = type; /* set "was" field */
4879 return newop;
4880 }
4881 op_free(first);
dd3e51dc
VP		 4882 if (other->op_type == OP_LEAVE)
4883 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
2474a784
FC		 4884 else if (other->op_type == OP_MATCH
4885 || other->op_type == OP_SUBST
4886 || other->op_type == OP_TRANS)
4887 /* Mark the op as being unbindable with =~ */
4888 other->op_flags |= OPf_SPECIAL;
79072805
LW		 4889 return other;
4890 }
4891 else {
7921d0f2 4892 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 4893 const OP *o2 = other;
7921d0f2
DM		 4894 if ( ! (o2->op_type == OP_LIST
4895 && (( o2 = cUNOPx(o2)->op_first))
4896 && o2->op_type == OP_PUSHMARK
4897 && (( o2 = o2->op_sibling)) )
4898 )
4899 o2 = other;
4900 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4901 || o2->op_type == OP_PADHV)
4902 && o2->op_private & OPpLVAL_INTRO
a2a5de95 4903 && !(o2->op_private & OPpPAD_STATE))
7921d0f2 4904 {
d1d15184
NC		 4905 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4906 "Deprecated use of my() in false conditional");
7921d0f2
DM		 4907 }
4908
5f66b61c 4909 *otherp = NULL;
d6fee5c7
DM		 4910 if (first->op_type == OP_CONST)
4911 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4912 if (PL_madskills) {
4913 first = newUNOP(OP_NULL, 0, first);
4914 op_getmad(other, first, '2');
4915 first->op_targ = type; /* set "was" field */
4916 }
4917 else
4918 op_free(other);
79072805
LW		 4919 return first;
4920 }
4921 }
041457d9
DM		 4922 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4923 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 4924 {
b22e6366
AL		 4925 const OP * const k1 = ((UNOP*)first)->op_first;
4926 const OP * const k2 = k1->op_sibling;
a6006777 4927 OPCODE warnop = 0;
4928 switch (first->op_type)
4929 {
4930 case OP_NULL:
4931 if (k2 && k2->op_type == OP_READLINE
4932 && (k2->op_flags & OPf_STACKED)
1c846c1f 4933 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 4934 {
a6006777 4935 warnop = k2->op_type;
72b16652 4936 }
a6006777 4937 break;
4938
4939 case OP_SASSIGN:
68dc0745 4940 if (k1->op_type == OP_READDIR
4941 || k1->op_type == OP_GLOB
72b16652 4942 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 4943 || k1->op_type == OP_EACH)
72b16652
GS		 4944 {
4945 warnop = ((k1->op_type == OP_NULL)
eb160463 4946 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 4947 }
a6006777 4948 break;
4949 }
8ebc5c01 4950 if (warnop) {
6867be6d 4951 const line_t oldline = CopLINE(PL_curcop);
53a7735b 4952 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 4953 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 4954 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 4955 PL_op_desc[warnop],
68dc0745 4956 ((warnop == OP_READLINE || warnop == OP_GLOB)
4957 ? " construct" : "() operator"));
57843af0 4958 CopLINE_set(PL_curcop, oldline);
8ebc5c01 4959 }
a6006777 4960 }
79072805
LW		 4961
4962 if (!other)
4963 return first;
4964
c963b151 4965 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 4966 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4967
b7dc083c 4968 NewOp(1101, logop, 1, LOGOP);
79072805 4969
eb160463 4970 logop->op_type = (OPCODE)type;
22c35a8c 4971 logop->op_ppaddr = PL_ppaddr[type];
79072805 4972 logop->op_first = first;
585ec06d 4973 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 4974 logop->op_other = LINKLIST(other);
eb160463 4975 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4976
4977 /* establish postfix order */
4978 logop->op_next = LINKLIST(first);
4979 first->op_next = (OP*)logop;
4980 first->op_sibling = other;
4981
463d09e6
RGS		 4982 CHECKOP(type,logop);
4983
edbe35ea 4984 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
11343788 4985 other->op_next = o;
79072805 4986
11343788 4987 return o;
79072805
LW		 4988}
4989
d67eb5f4
Z		 4990/*
4991=for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
4992
4993Constructs, checks, and returns a conditional-expression (C<cond_expr>)
4994op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4995will be set automatically, and, shifted up eight bits, the eight bits of
4996C<op_private>, except that the bit with value 1 is automatically set.
4997I<first> supplies the expression selecting between the two branches,
4998and I<trueop> and I<falseop> supply the branches; they are consumed by
4999this function and become part of the constructed op tree.
5000
5001=cut
5002*/
5003
79072805 5004OP *
864dbfa3 5005Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 5006{
27da23d5 5007 dVAR;
1a67a97c
SM		 5008 LOGOP *logop;
5009 OP *start;
11343788 5010 OP *o;
71c4dbc3 5011 OP *cstop;
79072805 5012
7918f24d
NC		 5013 PERL_ARGS_ASSERT_NEWCONDOP;
5014
b1cb66bf 5015 if (!falseop)
5016 return newLOGOP(OP_AND, 0, first, trueop);
5017 if (!trueop)
5018 return newLOGOP(OP_OR, 0, first, falseop);
79072805 5019
8990e307 5020 scalarboolean(first);
71c4dbc3 5021 if ((cstop = search_const(first))) {
5b6782b2 5022 /* Left or right arm of the conditional? */
71c4dbc3 5023 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5b6782b2
NC		 5024 OP *live = left ? trueop : falseop;
5025 OP *const dead = left ? falseop : trueop;
71c4dbc3
VP		 5026 if (cstop->op_private & OPpCONST_BARE &&
5027 cstop->op_private & OPpCONST_STRICT) {
5028 no_bareword_allowed(cstop);
b22e6366 5029 }
5b6782b2
NC		 5030 if (PL_madskills) {
5031 /* This is all dead code when PERL_MAD is not defined. */
5032 live = newUNOP(OP_NULL, 0, live);
5033 op_getmad(first, live, 'C');
5034 op_getmad(dead, live, left ? 'e' : 't');
5035 } else {
5036 op_free(first);
5037 op_free(dead);
79072805 5038 }
ef9da979
FC		 5039 if (live->op_type == OP_LEAVE)
5040 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
2474a784
FC		 5041 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5042 || live->op_type == OP_TRANS)
5043 /* Mark the op as being unbindable with =~ */
5044 live->op_flags |= OPf_SPECIAL;
5b6782b2 5045 return live;
79072805 5046 }
1a67a97c
SM		 5047 NewOp(1101, logop, 1, LOGOP);
5048 logop->op_type = OP_COND_EXPR;
5049 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5050 logop->op_first = first;
585ec06d 5051 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 5052 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 5053 logop->op_other = LINKLIST(trueop);
5054 logop->op_next = LINKLIST(falseop);
79072805 5055
463d09e6
RGS		 5056 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5057 logop);
79072805
LW		 5058
5059 /* establish postfix order */
1a67a97c
SM		 5060 start = LINKLIST(first);
5061 first->op_next = (OP*)logop;
79072805 5062
b1cb66bf 5063 first->op_sibling = trueop;
5064 trueop->op_sibling = falseop;
1a67a97c 5065 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 5066
1a67a97c 5067 trueop->op_next = falseop->op_next = o;
79072805 5068
1a67a97c 5069 o->op_next = start;
11343788 5070 return o;
79072805
LW		 5071}
5072
d67eb5f4
Z		 5073/*
5074=for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5075
5076Constructs and returns a C<range> op, with subordinate C<flip> and
5077C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5078C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5079for both the C<flip> and C<range> ops, except that the bit with value
50801 is automatically set. I<left> and I<right> supply the expressions
5081controlling the endpoints of the range; they are consumed by this function
5082and become part of the constructed op tree.
5083
5084=cut
5085*/
5086
79072805 5087OP *
864dbfa3 5088Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 5089{
27da23d5 5090 dVAR;
1a67a97c 5091 LOGOP *range;
79072805
LW		 5092 OP *flip;
5093 OP *flop;
1a67a97c 5094 OP *leftstart;
11343788 5095 OP *o;
79072805 5096
7918f24d
NC		 5097 PERL_ARGS_ASSERT_NEWRANGE;
5098
1a67a97c 5099 NewOp(1101, range, 1, LOGOP);
79072805 5100
1a67a97c
SM		 5101 range->op_type = OP_RANGE;
5102 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5103 range->op_first = left;
5104 range->op_flags = OPf_KIDS;
5105 leftstart = LINKLIST(left);
5106 range->op_other = LINKLIST(right);
eb160463 5107 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 5108
5109 left->op_sibling = right;
5110
1a67a97c
SM		 5111 range->op_next = (OP*)range;
5112 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 5113 flop = newUNOP(OP_FLOP, 0, flip);
11343788 5114 o = newUNOP(OP_NULL, 0, flop);
79072805 5115 linklist(flop);
1a67a97c 5116 range->op_next = leftstart;
79072805
LW		 5117
5118 left->op_next = flip;
5119 right->op_next = flop;
5120
1a67a97c
SM		 5121 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5122 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 5123 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 5124 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5125
5126 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5127 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5128
11343788 5129 flip->op_next = o;
79072805 5130 if (!flip->op_private || !flop->op_private)
11343788 5131 linklist(o); /* blow off optimizer unless constant */
79072805 5132
11343788 5133 return o;
79072805
LW		 5134}
5135
d67eb5f4
Z		 5136/*
5137=for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5138
5139Constructs, checks, and returns an op tree expressing a loop. This is
5140only a loop in the control flow through the op tree; it does not have
5141the heavyweight loop structure that allows exiting the loop by C<last>
5142and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5143top-level op, except that some bits will be set automatically as required.
5144I<expr> supplies the expression controlling loop iteration, and I<block>
5145supplies the body of the loop; they are consumed by this function and
5146become part of the constructed op tree. I<debuggable> is currently
5147unused and should always be 1.
5148
5149=cut
5150*/
5151
79072805 5152OP *
864dbfa3 5153Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 5154{
97aff369 5155 dVAR;
463ee0b2 5156 OP* listop;
11343788 5157 OP* o;
73d840c0 5158 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 5159 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 5160
5161 PERL_UNUSED_ARG(debuggable);
93a17b20 5162
463ee0b2
LW		 5163 if (expr) {
5164 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5165 return block; /* do {} while 0 does once */
114c60ec
BG		 5166 if (expr->op_type == OP_READLINE
5167 || expr->op_type == OP_READDIR
5168 || expr->op_type == OP_GLOB
fb73857a 5169 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 5170 expr = newUNOP(OP_DEFINED, 0,
54b9620d 5171 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 5172 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 5173 const OP * const k1 = ((UNOP*)expr)->op_first;
5174 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 5175 switch (expr->op_type) {
1c846c1f 5176 case OP_NULL:
114c60ec 5177 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
55d729e4 5178 && (k2->op_flags & OPf_STACKED)
1c846c1f 5179 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 5180 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 5181 break;
55d729e4
GS		 5182
5183 case OP_SASSIGN:
06dc7ac6 5184 if (k1 && (k1->op_type == OP_READDIR
55d729e4 5185 || k1->op_type == OP_GLOB
6531c3e6 5186 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
06dc7ac6 5187 || k1->op_type == OP_EACH))
55d729e4
GS		 5188 expr = newUNOP(OP_DEFINED, 0, expr);
5189 break;
5190 }
774d564b 5191 }
463ee0b2 5192 }
93a17b20 5193
e1548254
RGS		 5194 /* if block is null, the next append_elem() would put UNSTACK, a scalar
5195 * op, in listop. This is wrong. [perl #27024] */
5196 if (!block)
5197 block = newOP(OP_NULL, 0);
8990e307 5198 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 5199 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 5200
883ffac3
CS		 5201 if (listop)
5202 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 5203
11343788
MB		 5204 if (once && o != listop)
5205 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 5206
11343788
MB		 5207 if (o == listop)
5208 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 5209
11343788
MB		 5210 o->op_flags |= flags;
5211 o = scope(o);
5212 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5213 return o;
79072805
LW		 5214}
5215
d67eb5f4
Z		 5216/*
5217=for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|I32 whileline|OP *expr|OP *block|OP *cont|I32 has_my
5218
5219Constructs, checks, and returns an op tree expressing a C<while> loop.
5220This is a heavyweight loop, with structure that allows exiting the loop
5221by C<last> and suchlike.
5222
5223I<loop> is an optional preconstructed C<enterloop> op to use in the
5224loop; if it is null then a suitable op will be constructed automatically.
5225I<expr> supplies the loop's controlling expression. I<block> supplies the
5226main body of the loop, and I<cont> optionally supplies a C<continue> block
5227that operates as a second half of the body. All of these optree inputs
5228are consumed by this function and become part of the constructed op tree.
5229
5230I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5231op and, shifted up eight bits, the eight bits of C<op_private> for
5232the C<leaveloop> op, except that (in both cases) some bits will be set
5233automatically. I<debuggable> is currently unused and should always be 1.
5234I<whileline> is the line number that should be attributed to the loop's
5235controlling expression. I<has_my> can be supplied as true to force the
5236loop body to be enclosed in its own scope.
5237
5238=cut
5239*/
5240
79072805 5241OP *
a034e688
DM		 5242Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
5243whileline, OP *expr, OP *block, OP *cont, I32 has_my)
79072805 5244{
27da23d5 5245 dVAR;
79072805 5246 OP *redo;
c445ea15 5247 OP *next = NULL;
79072805 5248 OP *listop;
11343788 5249 OP *o;
1ba6ee2b 5250 U8 loopflags = 0;
46c461b5
AL		 5251
5252 PERL_UNUSED_ARG(debuggable);
79072805 5253
2d03de9c 5254 if (expr) {
114c60ec
BG		 5255 if (expr->op_type == OP_READLINE
5256 || expr->op_type == OP_READDIR
5257 || expr->op_type == OP_GLOB
2d03de9c
AL		 5258 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5259 expr = newUNOP(OP_DEFINED, 0,
5260 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5261 } else if (expr->op_flags & OPf_KIDS) {
5262 const OP * const k1 = ((UNOP*)expr)->op_first;
5263 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5264 switch (expr->op_type) {
5265 case OP_NULL:
114c60ec 5266 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
2d03de9c
AL		 5267 && (k2->op_flags & OPf_STACKED)
5268 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5269 expr = newUNOP(OP_DEFINED, 0, expr);
5270 break;
55d729e4 5271
2d03de9c 5272 case OP_SASSIGN:
72c8de1a 5273 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 5274 || k1->op_type == OP_GLOB
5275 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
72c8de1a 5276 || k1->op_type == OP_EACH))
2d03de9c
AL		 5277 expr = newUNOP(OP_DEFINED, 0, expr);
5278 break;
5279 }
55d729e4 5280 }
748a9306 5281 }
79072805
LW		 5282
5283 if (!block)
5284 block = newOP(OP_NULL, 0);
a034e688 5285 else if (cont || has_my) {
87246558
GS		 5286 block = scope(block);
5287 }
79072805 5288
1ba6ee2b 5289 if (cont) {
79072805 5290 next = LINKLIST(cont);
1ba6ee2b 5291 }
fb73857a 5292 if (expr) {
551405c4 5293 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 5294 if (!next)
5295 next = unstack;
5296 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 5297 }
79072805 5298
ce3e5c45 5299 assert(block);
463ee0b2 5300 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
ce3e5c45 5301 assert(listop);
79072805
LW		 5302 redo = LINKLIST(listop);
5303
5304 if (expr) {
53a7735b 5305 PL_parser->copline = (line_t)whileline;
883ffac3
CS		 5306 scalar(listop);
5307 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 5308 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 5309 op_free(expr); /* oops, it's a while (0) */
463ee0b2 5310 op_free((OP*)loop);
5f66b61c 5311 return NULL; /* listop already freed by new_logop */
463ee0b2 5312 }
883ffac3 5313 if (listop)
497b47a8 5314 ((LISTOP*)listop)->op_last->op_next =
883ffac3 5315 (o == listop ? redo : LINKLIST(o));
79072805
LW		 5316 }
5317 else
11343788 5318 o = listop;
79072805
LW		 5319
5320 if (!loop) {
b7dc083c 5321 NewOp(1101,loop,1,LOOP);
79072805 5322 loop->op_type = OP_ENTERLOOP;
22c35a8c 5323 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 5324 loop->op_private = 0;
5325 loop->op_next = (OP*)loop;
5326 }
5327
11343788 5328 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 5329
5330 loop->op_redoop = redo;
11343788 5331 loop->op_lastop = o;
1ba6ee2b 5332 o->op_private |= loopflags;
79072805
LW		 5333
5334 if (next)
5335 loop->op_nextop = next;
5336 else
11343788 5337 loop->op_nextop = o;
79072805 5338
11343788
MB		 5339 o->op_flags |= flags;
5340 o->op_private |= (flags >> 8);
5341 return o;
79072805
LW		 5342}
5343
d67eb5f4
Z		 5344/*
5345=for apidoc Am|OP *|newFOROP|I32 flags|char *label|line_t forline|OP *sv|OP *expr|OP *block|OP *cont
5346
5347Constructs, checks, and returns an op tree expressing a C<foreach>
5348loop (iteration through a list of values). This is a heavyweight loop,
5349with structure that allows exiting the loop by C<last> and suchlike.
5350
5351I<sv> optionally supplies the variable that will be aliased to each
5352item in turn; if null, it defaults to C<$_> (either lexical or global).
5353I<expr> supplies the list of values to iterate over. I<block> supplies
5354the main body of the loop, and I<cont> optionally supplies a C<continue>
5355block that operates as a second half of the body. All of these optree
5356inputs are consumed by this function and become part of the constructed
5357op tree.
5358
5359I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5360op and, shifted up eight bits, the eight bits of C<op_private> for
5361the C<leaveloop> op, except that (in both cases) some bits will be set
5362automatically. I<forline> is the line number that should be attributed
5363to the loop's list expression. If I<label> is non-null, it supplies
5364the name of a label to attach to the state op at the start of the loop;
5365this function takes ownership of the memory pointed at by I<label>,
5366and will free it.
5367
5368=cut
5369*/
5370
79072805 5371OP *
66a1b24b 5372Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
79072805 5373{
27da23d5 5374 dVAR;
79072805 5375 LOOP *loop;
fb73857a 5376 OP *wop;
4bbc6d12 5377 PADOFFSET padoff = 0;
4633a7c4 5378 I32 iterflags = 0;
241416b8 5379 I32 iterpflags = 0;
d4c19fe8 5380 OP *madsv = NULL;
79072805 5381
7918f24d
NC		 5382 PERL_ARGS_ASSERT_NEWFOROP;
5383
79072805 5384 if (sv) {
85e6fe83 5385 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 5386 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 5387 sv->op_type = OP_RV2GV;
22c35a8c 5388 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0be9a6bb
RH		 5389
5390 /* The op_type check is needed to prevent a possible segfault
5391 * if the loop variable is undeclared and 'strict vars' is in
5392 * effect. This is illegal but is nonetheless parsed, so we
5393 * may reach this point with an OP_CONST where we're expecting
5394 * an OP_GV.
5395 */
5396 if (cUNOPx(sv)->op_first->op_type == OP_GV
5397 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
0d863452 5398 iterpflags |= OPpITER_DEF;
79072805 5399 }
85e6fe83 5400 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 5401 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 5402 padoff = sv->op_targ;
eb8433b7
NC		 5403 if (PL_madskills)
5404 madsv = sv;
5405 else {
5406 sv->op_targ = 0;
5407 op_free(sv);
5408 }
5f66b61c 5409 sv = NULL;
85e6fe83 5410 }
79072805 5411 else
cea2e8a9 5412 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
f8503592
NC		 5413 if (padoff) {
5414 SV *const namesv = PAD_COMPNAME_SV(padoff);
5415 STRLEN len;
5416 const char *const name = SvPV_const(namesv, len);
5417
5418 if (len == 2 && name[0] == '$' && name[1] == '_')
5419 iterpflags |= OPpITER_DEF;
5420 }
79072805
LW		 5421 }
5422 else {
f8f98e0a 5423 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
00b1698f 5424 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 5425 sv = newGVOP(OP_GV, 0, PL_defgv);
5426 }
5427 else {
5428 padoff = offset;
aabe9514 5429 }
0d863452 5430 iterpflags |= OPpITER_DEF;
79072805 5431 }
5f05dabc 5432 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 5433 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 5434 iterflags |= OPf_STACKED;
5435 }
89ea2908
GA		 5436 else if (expr->op_type == OP_NULL &&
5437 (expr->op_flags & OPf_KIDS) &&
5438 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5439 {
5440 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5441 * set the STACKED flag to indicate that these values are to be
5442 * treated as min/max values by 'pp_iterinit'.
5443 */
d4c19fe8 5444 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 5445 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 5446 OP* const left = range->op_first;
5447 OP* const right = left->op_sibling;
5152d7c7 5448 LISTOP* listop;
89ea2908
GA		 5449
5450 range->op_flags &= ~OPf_KIDS;
5f66b61c 5451 range->op_first = NULL;
89ea2908 5452
5152d7c7 5453 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 5454 listop->op_first->op_next = range->op_next;
5455 left->op_next = range->op_other;
5152d7c7
GS		 5456 right->op_next = (OP*)listop;
5457 listop->op_next = listop->op_first;
89ea2908 5458
eb8433b7
NC		 5459#ifdef PERL_MAD
5460 op_getmad(expr,(OP*)listop,'O');
5461#else
89ea2908 5462 op_free(expr);
eb8433b7 5463#endif
5152d7c7 5464 expr = (OP*)(listop);
93c66552 5465 op_null(expr);
89ea2908
GA		 5466 iterflags |= OPf_STACKED;
5467 }
5468 else {
5469 expr = mod(force_list(expr), OP_GREPSTART);
5470 }
5471
4633a7c4 5472 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 5473 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 5474 assert(!loop->op_next);
241416b8 5475 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 5476 * for our $x () sets OPpOUR_INTRO */
c5661c80 5477 loop->op_private = (U8)iterpflags;
b7dc083c 5478#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 5479 {
5480 LOOP *tmp;
5481 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 5482 Copy(loop,tmp,1,LISTOP);
bfafaa29 5483 S_op_destroy(aTHX_ (OP*)loop);
155aba94
GS		 5484 loop = tmp;
5485 }
b7dc083c 5486#else
10edeb5d 5487 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
1c846c1f 5488#endif
85e6fe83 5489 loop->op_targ = padoff;
a034e688 5490 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 5491 if (madsv)
5492 op_getmad(madsv, (OP*)loop, 'v');
53a7735b 5493 PL_parser->copline = forline;
fb73857a 5494 return newSTATEOP(0, label, wop);
79072805
LW		 5495}
5496
d67eb5f4
Z		 5497/*
5498=for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5499
5500Constructs, checks, and returns a loop-exiting op (such as C<goto>
5501or C<last>). I<type> is the opcode. I<label> supplies the parameter
5502determining the target of the op; it is consumed by this function and
5503become part of the constructed op tree.
5504
5505=cut
5506*/
5507
8990e307 5508OP*
864dbfa3 5509Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 5510{
97aff369 5511 dVAR;
11343788 5512 OP *o;
2d8e6c8d 5513
7918f24d
NC		 5514 PERL_ARGS_ASSERT_NEWLOOPEX;
5515
e69777c1
GG		 5516 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5517
8990e307 5518 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 5519 /* "last()" means "last" */
5520 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5521 o = newOP(type, OPf_SPECIAL);
5522 else {
ea71c68d 5523 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4ea561bc 5524 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
666ea192 5525 : ""));
cdaebead 5526 }
eb8433b7
NC		 5527#ifdef PERL_MAD
5528 op_getmad(label,o,'L');
5529#else
8990e307 5530 op_free(label);
eb8433b7 5531#endif
8990e307
LW		 5532 }
5533 else {
e3aba57a
RGS		 5534 /* Check whether it's going to be a goto &function */
5535 if (label->op_type == OP_ENTERSUB
5536 && !(label->op_flags & OPf_STACKED))
a0d0e21e 5537 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 5538 o = newUNOP(type, OPf_STACKED, label);
8990e307 5539 }
3280af22 5540 PL_hints |= HINT_BLOCK_SCOPE;
11343788 5541 return o;
8990e307
LW		 5542}
5543
0d863452
RH		 5544/* if the condition is a literal array or hash
5545 (or @{ ... } etc), make a reference to it.
5546 */
5547STATIC OP *
5548S_ref_array_or_hash(pTHX_ OP *cond)
5549{
5550 if (cond
5551 && (cond->op_type == OP_RV2AV
5552 || cond->op_type == OP_PADAV
5553 || cond->op_type == OP_RV2HV
5554 || cond->op_type == OP_PADHV))
5555
5556 return newUNOP(OP_REFGEN,
5557 0, mod(cond, OP_REFGEN));
5558
329a333e
DL		 5559 else if(cond
5560 && (cond->op_type == OP_ASLICE
5561 || cond->op_type == OP_HSLICE)) {
5562
5563 /* anonlist now needs a list from this op, was previously used in
5564 * scalar context */
5565 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5566 cond->op_flags |= OPf_WANT_LIST;
5567
5568 return newANONLIST(mod(cond, OP_ANONLIST));
5569 }
5570
0d863452
RH		 5571 else
5572 return cond;
5573}
5574
5575/* These construct the optree fragments representing given()
5576 and when() blocks.
5577
5578 entergiven and enterwhen are LOGOPs; the op_other pointer
5579 points up to the associated leave op. We need this so we
5580 can put it in the context and make break/continue work.
5581 (Also, of course, pp_enterwhen will jump straight to
5582 op_other if the match fails.)
5583 */
5584
4136a0f7 5585STATIC OP *
0d863452
RH		 5586S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5587 I32 enter_opcode, I32 leave_opcode,
5588 PADOFFSET entertarg)
5589{
97aff369 5590 dVAR;
0d863452
RH		 5591 LOGOP *enterop;
5592 OP *o;
5593
7918f24d
NC		 5594 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5595
0d863452 5596 NewOp(1101, enterop, 1, LOGOP);
61a59f30 5597 enterop->op_type = (Optype)enter_opcode;
0d863452
RH		 5598 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5599 enterop->op_flags = (U8) OPf_KIDS;
5600 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5601 enterop->op_private = 0;
5602
5603 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5604
5605 if (cond) {
5606 enterop->op_first = scalar(cond);
5607 cond->op_sibling = block;
5608
5609 o->op_next = LINKLIST(cond);
5610 cond->op_next = (OP *) enterop;
5611 }
5612 else {
5613 /* This is a default {} block */
5614 enterop->op_first = block;
5615 enterop->op_flags |= OPf_SPECIAL;
5616
5617 o->op_next = (OP *) enterop;
5618 }
5619
5620 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5621 entergiven and enterwhen both
5622 use ck_null() */
5623
5624 enterop->op_next = LINKLIST(block);
5625 block->op_next = enterop->op_other = o;
5626
5627 return o;
5628}
5629
5630/* Does this look like a boolean operation? For these purposes
5631 a boolean operation is:
5632 - a subroutine call [*]
5633 - a logical connective
5634 - a comparison operator
5635 - a filetest operator, with the exception of -s -M -A -C
5636 - defined(), exists() or eof()
5637 - /$re/ or $foo =~ /$re/
5638
5639 [*] possibly surprising
5640 */
4136a0f7 5641STATIC bool
ef519e13 5642S_looks_like_bool(pTHX_ const OP *o)
0d863452 5643{
97aff369 5644 dVAR;
7918f24d
NC		 5645
5646 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5647
0d863452
RH		 5648 switch(o->op_type) {
5649 case OP_OR:
f92e1a16 5650 case OP_DOR:
0d863452
RH		 5651 return looks_like_bool(cLOGOPo->op_first);
5652
5653 case OP_AND:
5654 return (
5655 looks_like_bool(cLOGOPo->op_first)
5656 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5657
1e1d4b91 5658 case OP_NULL:
08fe1c44 5659 case OP_SCALAR:
1e1d4b91
JJ		 5660 return (
5661 o->op_flags & OPf_KIDS
5662 && looks_like_bool(cUNOPo->op_first));
5663
0d863452
RH		 5664 case OP_ENTERSUB:
5665
5666 case OP_NOT: case OP_XOR:
0d863452
RH		 5667
5668 case OP_EQ: case OP_NE: case OP_LT:
5669 case OP_GT: case OP_LE: case OP_GE:
5670
5671 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5672 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5673
5674 case OP_SEQ: case OP_SNE: case OP_SLT:
5675 case OP_SGT: case OP_SLE: case OP_SGE:
5676
5677 case OP_SMARTMATCH:
5678
5679 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5680 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5681 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5682 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5683 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5684 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5685 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5686 case OP_FTTEXT: case OP_FTBINARY:
5687
5688 case OP_DEFINED: case OP_EXISTS:
5689 case OP_MATCH: case OP_EOF:
5690
f118ea0d
RGS		 5691 case OP_FLOP:
5692
0d863452
RH		 5693 return TRUE;
5694
5695 case OP_CONST:
5696 /* Detect comparisons that have been optimized away */
5697 if (cSVOPo->op_sv == &PL_sv_yes
5698 || cSVOPo->op_sv == &PL_sv_no)
5699
5700 return TRUE;
6e03d743
RGS		 5701 else
5702 return FALSE;
6e03d743 5703
0d863452
RH		 5704 /* FALL THROUGH */
5705 default:
5706 return FALSE;
5707 }
5708}
5709
d67eb5f4
Z		 5710/*
5711=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5712
5713Constructs, checks, and returns an op tree expressing a C<given> block.
5714I<cond> supplies the expression that will be locally assigned to a lexical
5715variable, and I<block> supplies the body of the C<given> construct; they
5716are consumed by this function and become part of the constructed op tree.
5717I<defsv_off> is the pad offset of the scalar lexical variable that will
5718be affected.
5719
5720=cut
5721*/
5722
0d863452
RH		 5723OP *
5724Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5725{
97aff369 5726 dVAR;
7918f24d 5727 PERL_ARGS_ASSERT_NEWGIVENOP;
0d863452
RH		 5728 return newGIVWHENOP(
5729 ref_array_or_hash(cond),
5730 block,
5731 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5732 defsv_off);
5733}
5734
d67eb5f4
Z		 5735/*
5736=for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5737
5738Constructs, checks, and returns an op tree expressing a C<when> block.
5739I<cond> supplies the test expression, and I<block> supplies the block
5740that will be executed if the test evaluates to true; they are consumed
5741by this function and become part of the constructed op tree. I<cond>
5742will be interpreted DWIMically, often as a comparison against C<$_>,
5743and may be null to generate a C<default> block.
5744
5745=cut
5746*/
5747
0d863452
RH		 5748OP *
5749Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5750{
ef519e13 5751 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 5752 OP *cond_op;
5753
7918f24d
NC		 5754 PERL_ARGS_ASSERT_NEWWHENOP;
5755
0d863452
RH		 5756 if (cond_llb)
5757 cond_op = cond;
5758 else {
5759 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5760 newDEFSVOP(),
5761 scalar(ref_array_or_hash(cond)));
5762 }
5763
5764 return newGIVWHENOP(
5765 cond_op,
5766 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5767 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5768}
5769
7dafbf52 5770/*
d67eb5f4
Z		 5771=head1 Embedding Functions
5772
7dafbf52
DM		 5773=for apidoc cv_undef
5774
5775Clear out all the active components of a CV. This can happen either
5776by an explicit C<undef &foo>, or by the reference count going to zero.
5777In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5778children can still follow the full lexical scope chain.
5779
5780=cut
5781*/
5782
79072805 5783void
864dbfa3 5784Perl_cv_undef(pTHX_ CV *cv)
79072805 5785{
27da23d5 5786 dVAR;
503de470 5787
7918f24d
NC		 5788 PERL_ARGS_ASSERT_CV_UNDEF;
5789
503de470
DM		 5790 DEBUG_X(PerlIO_printf(Perl_debug_log,
5791 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5792 PTR2UV(cv), PTR2UV(PL_comppad))
5793 );
5794
a636914a 5795#ifdef USE_ITHREADS
aed2304a 5796 if (CvFILE(cv) && !CvISXSUB(cv)) {
35f1c1c7 5797 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 5798 Safefree(CvFILE(cv));
a636914a 5799 }
b3123a61 5800 CvFILE(cv) = NULL;
a636914a
RH		 5801#endif
5802
aed2304a 5803 if (!CvISXSUB(cv) && CvROOT(cv)) {
bb172083 5804 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
cea2e8a9 5805 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 5806 ENTER;
a0d0e21e 5807
f3548bdc 5808 PAD_SAVE_SETNULLPAD();
a0d0e21e 5809
282f25c9 5810 op_free(CvROOT(cv));
5f66b61c
AL		 5811 CvROOT(cv) = NULL;
5812 CvSTART(cv) = NULL;
8990e307 5813 LEAVE;
79072805 5814 }
ad64d0ec 5815 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
b3f91e91 5816 CvGV_set(cv, NULL);
a3985cdc
DM		 5817
5818 pad_undef(cv);
5819
7dafbf52
DM		 5820 /* remove CvOUTSIDE unless this is an undef rather than a free */
5821 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5822 if (!CvWEAKOUTSIDE(cv))
5823 SvREFCNT_dec(CvOUTSIDE(cv));
601f1833 5824 CvOUTSIDE(cv) = NULL;
7dafbf52 5825 }
beab0874 5826 if (CvCONST(cv)) {
ad64d0ec 5827 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
beab0874
JT		 5828 CvCONST_off(cv);
5829 }
d04ba589 5830 if (CvISXSUB(cv) && CvXSUB(cv)) {
96a5add6 5831 CvXSUB(cv) = NULL;
50762d59 5832 }
cfc1e951 5833 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
803f2748 5834 * ref status of CvOUTSIDE and CvGV */
cfc1e951 5835 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
79072805
LW		 5836}
5837
3fe9a6f1 5838void
cbf82dd0
NC		 5839Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5840 const STRLEN len)
5841{
7918f24d
NC		 5842 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5843
cbf82dd0
NC		 5844 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5845 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5846 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5847 || (p && (len != SvCUR(cv) /* Not the same length. */
5848 || memNE(p, SvPVX_const(cv), len))))
5849 && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 5850 SV* const msg = sv_newmortal();
a0714e2c 5851 SV* name = NULL;
3fe9a6f1 5852
5853 if (gv)
bd61b366 5854 gv_efullname3(name = sv_newmortal(), gv, NULL);
6502358f 5855 sv_setpvs(msg, "Prototype mismatch:");
46fc3d4c 5856 if (name)
be2597df 5857 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
3fe9a6f1 5858 if (SvPOK(cv))
be2597df 5859 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
ebe643b9 5860 else
396482e1
GA		 5861 sv_catpvs(msg, ": none");
5862 sv_catpvs(msg, " vs ");
46fc3d4c 5863 if (p)
cbf82dd0 5864 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
46fc3d4c 5865 else
396482e1 5866 sv_catpvs(msg, "none");
be2597df 5867 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 5868 }
5869}
5870
35f1c1c7
SB		 5871static void const_sv_xsub(pTHX_ CV* cv);
5872
beab0874 5873/*
ccfc67b7
JH		 5874
5875=head1 Optree Manipulation Functions
5876
beab0874
JT		 5877=for apidoc cv_const_sv
5878
5879If C<cv> is a constant sub eligible for inlining. returns the constant
5880value returned by the sub. Otherwise, returns NULL.
5881
5882Constant subs can be created with C<newCONSTSUB> or as described in
5883L<perlsub/"Constant Functions">.
5884
5885=cut
5886*/
760ac839 5887SV *
d45f5b30 5888Perl_cv_const_sv(pTHX_ const CV *const cv)
760ac839 5889{
96a5add6 5890 PERL_UNUSED_CONTEXT;
5069cc75
NC		 5891 if (!cv)
5892 return NULL;
5893 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5894 return NULL;
ad64d0ec 5895 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
fe5e78ed 5896}
760ac839 5897
b5c19bd7
DM		 5898/* op_const_sv: examine an optree to determine whether it's in-lineable.
5899 * Can be called in 3 ways:
5900 *
5901 * !cv
5902 * look for a single OP_CONST with attached value: return the value
5903 *
5904 * cv && CvCLONE(cv) && !CvCONST(cv)
5905 *
5906 * examine the clone prototype, and if contains only a single
5907 * OP_CONST referencing a pad const, or a single PADSV referencing
5908 * an outer lexical, return a non-zero value to indicate the CV is
5909 * a candidate for "constizing" at clone time
5910 *
5911 * cv && CvCONST(cv)
5912 *
5913 * We have just cloned an anon prototype that was marked as a const
5914 * candidiate. Try to grab the current value, and in the case of
5915 * PADSV, ignore it if it has multiple references. Return the value.
5916 */
5917
fe5e78ed 5918SV *
6867be6d 5919Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 5920{
97aff369 5921 dVAR;
a0714e2c 5922 SV *sv = NULL;
fe5e78ed 5923
c631f32b
GG		 5924 if (PL_madskills)
5925 return NULL;
5926
0f79a09d 5927 if (!o)
a0714e2c 5928 return NULL;
1c846c1f
NIS		 5929
5930 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 5931 o = cLISTOPo->op_first->op_sibling;
5932
5933 for (; o; o = o->op_next) {
890ce7af 5934 const OPCODE type = o->op_type;
fe5e78ed 5935
1c846c1f 5936 if (sv && o->op_next == o)
fe5e78ed 5937 return sv;
e576b457
JT		 5938 if (o->op_next != o) {
5939 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5940 continue;
5941 if (type == OP_DBSTATE)
5942 continue;
5943 }
54310121 5944 if (type == OP_LEAVESUB || type == OP_RETURN)
5945 break;
5946 if (sv)
a0714e2c 5947 return NULL;
7766f137 5948 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 5949 sv = cSVOPo->op_sv;
b5c19bd7 5950 else if (cv && type == OP_CONST) {
dd2155a4 5951 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 5952 if (!sv)
a0714e2c 5953 return NULL;
b5c19bd7
DM		 5954 }
5955 else if (cv && type == OP_PADSV) {
5956 if (CvCONST(cv)) { /* newly cloned anon */
5957 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5958 /* the candidate should have 1 ref from this pad and 1 ref
5959 * from the parent */
5960 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 5961 return NULL;
beab0874 5962 sv = newSVsv(sv);
b5c19bd7
DM		 5963 SvREADONLY_on(sv);
5964 return sv;
5965 }
5966 else {
5967 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5968 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 5969 }
760ac839 5970 }
b5c19bd7 5971 else {
a0714e2c 5972 return NULL;
b5c19bd7 5973 }
760ac839
LW		 5974 }
5975 return sv;
5976}
5977
eb8433b7
NC		 5978#ifdef PERL_MAD
5979OP *
5980#else
09bef843 5981void
eb8433b7 5982#endif
09bef843
SB		 5983Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5984{
99129197
NC		 5985#if 0
5986 /* This would be the return value, but the return cannot be reached. */
eb8433b7
NC		 5987 OP* pegop = newOP(OP_NULL, 0);
5988#endif
5989
46c461b5
AL		 5990 PERL_UNUSED_ARG(floor);
5991
09bef843
SB		 5992 if (o)
5993 SAVEFREEOP(o);
5994 if (proto)
5995 SAVEFREEOP(proto);
5996 if (attrs)
5997 SAVEFREEOP(attrs);
5998 if (block)
5999 SAVEFREEOP(block);
6000 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
eb8433b7 6001#ifdef PERL_MAD
99129197 6002 NORETURN_FUNCTION_END;
eb8433b7 6003#endif
09bef843
SB		 6004}
6005
748a9306 6006CV *
864dbfa3 6007Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 6008{
5f66b61c 6009 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
09bef843
SB		 6010}
6011
6012CV *
6013Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6014{
27da23d5 6015 dVAR;
83ee9e09 6016 GV *gv;
5c144d81 6017 const char *ps;
52a9a866 6018 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
c445ea15 6019 register CV *cv = NULL;
beab0874 6020 SV *const_sv;
b48b272a
NC		 6021 /* If the subroutine has no body, no attributes, and no builtin attributes
6022 then it's just a sub declaration, and we may be able to get away with
6023 storing with a placeholder scalar in the symbol table, rather than a
6024 full GV and CV. If anything is present then it will take a full CV to
6025 store it. */
6026 const I32 gv_fetch_flags
eb8433b7
NC		 6027 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6028 || PL_madskills)
b48b272a 6029 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4ea561bc 6030 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
ed4a8a9b 6031 bool has_name;
8e742a20
MHM		 6032
6033 if (proto) {
6034 assert(proto->op_type == OP_CONST);
4ea561bc 6035 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8e742a20
MHM		 6036 }
6037 else
bd61b366 6038 ps = NULL;
8e742a20 6039
ed4a8a9b
NC		 6040 if (name) {
6041 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6042 has_name = TRUE;
6043 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 6044 SV * const sv = sv_newmortal();
c99da370
JH		 6045 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6046 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 6047 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
ed4a8a9b
NC		 6048 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6049 has_name = TRUE;
c1754fce
NC		 6050 } else if (PL_curstash) {
6051 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 6052 has_name = FALSE;
c1754fce
NC		 6053 } else {
6054 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 6055 has_name = FALSE;
c1754fce 6056 }
83ee9e09 6057
eb8433b7
NC		 6058 if (!PL_madskills) {
6059 if (o)
6060 SAVEFREEOP(o);
6061 if (proto)
6062 SAVEFREEOP(proto);
6063 if (attrs)
6064 SAVEFREEOP(attrs);
6065 }
3fe9a6f1 6066
09bef843 6067 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 6068 maximum a prototype before. */
6069 if (SvTYPE(gv) > SVt_NULL) {
ad64d0ec 6070 if (!SvPOK((const SV *)gv)
9b387841 6071 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
f248d071 6072 {
9b387841 6073 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 6074 }
ea726b52 6075 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
55d729e4
GS		 6076 }
6077 if (ps)
ad64d0ec 6078 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
55d729e4 6079 else
ad64d0ec 6080 sv_setiv(MUTABLE_SV(gv), -1);
e1a479c5 6081
3280af22
NIS		 6082 SvREFCNT_dec(PL_compcv);
6083 cv = PL_compcv = NULL;
beab0874 6084 goto done;
55d729e4
GS		 6085 }
6086
601f1833 6087 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 6088
eb8433b7
NC		 6089 if (!block || !ps || *ps || attrs
6090 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6091#ifdef PERL_MAD
6092 || block->op_type == OP_NULL
6093#endif
6094 )
a0714e2c 6095 const_sv = NULL;
beab0874 6096 else
601f1833 6097 const_sv = op_const_sv(block, NULL);
beab0874
JT		 6098
6099 if (cv) {
6867be6d 6100 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 6101
60ed1d8c
GS		 6102 /* if the subroutine doesn't exist and wasn't pre-declared
6103 * with a prototype, assume it will be AUTOLOADed,
6104 * skipping the prototype check
6105 */
6106 if (exists || SvPOK(cv))
cbf82dd0 6107 cv_ckproto_len(cv, gv, ps, ps_len);
68dc0745 6108 /* already defined (or promised)? */
60ed1d8c 6109 if (exists || GvASSUMECV(gv)) {
eb8433b7
NC		 6110 if ((!block
6111#ifdef PERL_MAD
6112 || block->op_type == OP_NULL
6113#endif
6114 )&& !attrs) {
d3cea301
SB		 6115 if (CvFLAGS(PL_compcv)) {
6116 /* might have had built-in attrs applied */
963d9ce9 6117 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
885ef6f5
GG		 6118 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6119 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
d3cea301 6120 }
aa689395 6121 /* just a "sub foo;" when &foo is already defined */
3280af22 6122 SAVEFREESV(PL_compcv);
aa689395 6123 goto done;
6124 }
eb8433b7
NC		 6125 if (block
6126#ifdef PERL_MAD
6127 && block->op_type != OP_NULL
6128#endif
6129 ) {
beab0874
JT		 6130 if (ckWARN(WARN_REDEFINE)
6131 || (CvCONST(cv)
6132 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6133 {
6867be6d 6134 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 6135 if (PL_parser && PL_parser->copline != NOLINE)
6136 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 6137 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 6138 CvCONST(cv) ? "Constant subroutine %s redefined"
6139 : "Subroutine %s redefined", name);
beab0874
JT		 6140 CopLINE_set(PL_curcop, oldline);
6141 }
eb8433b7
NC		 6142#ifdef PERL_MAD
6143 if (!PL_minus_c) /* keep old one around for madskills */
6144#endif
6145 {
6146 /* (PL_madskills unset in used file.) */
6147 SvREFCNT_dec(cv);
6148 }
601f1833 6149 cv = NULL;
79072805 6150 }
79072805
LW		 6151 }
6152 }
beab0874 6153 if (const_sv) {
f84c484e 6154 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 6155 if (cv) {
0768512c 6156 assert(!CvROOT(cv) && !CvCONST(cv));
ad64d0ec 6157 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
beab0874
JT		 6158 CvXSUBANY(cv).any_ptr = const_sv;
6159 CvXSUB(cv) = const_sv_xsub;
6160 CvCONST_on(cv);
d04ba589 6161 CvISXSUB_on(cv);
beab0874
JT		 6162 }
6163 else {
601f1833 6164 GvCV(gv) = NULL;
beab0874
JT		 6165 cv = newCONSTSUB(NULL, name, const_sv);
6166 }
e1a479c5
BB		 6167 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6168 (CvGV(cv) && GvSTASH(CvGV(cv)))
6169 ? GvSTASH(CvGV(cv))
6170 : CvSTASH(cv)
6171 ? CvSTASH(cv)
6172 : PL_curstash
6173 );
eb8433b7
NC		 6174 if (PL_madskills)
6175 goto install_block;
beab0874
JT		 6176 op_free(block);
6177 SvREFCNT_dec(PL_compcv);
6178 PL_compcv = NULL;
beab0874
JT		 6179 goto done;
6180 }
09330df8
Z		 6181 if (cv) { /* must reuse cv if autoloaded */
6182 /* transfer PL_compcv to cv */
6183 if (block
eb8433b7 6184#ifdef PERL_MAD
09330df8 6185 && block->op_type != OP_NULL
eb8433b7 6186#endif
09330df8 6187 ) {
eac910c8 6188 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
09330df8 6189 cv_undef(cv);
eac910c8 6190 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
09330df8
Z		 6191 if (!CvWEAKOUTSIDE(cv))
6192 SvREFCNT_dec(CvOUTSIDE(cv));
6193 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6194 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6195 CvOUTSIDE(PL_compcv) = 0;
6196 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6197 CvPADLIST(PL_compcv) = 0;
6198 /* inner references to PL_compcv must be fixed up ... */
6199 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6200 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6201 ++PL_sub_generation;
4c74a7df
DM		 6202 if (CvSTASH(cv))
6203 sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
09bef843
SB		 6204 }
6205 else {
09330df8
Z		 6206 /* Might have had built-in attributes applied -- propagate them. */
6207 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
09bef843 6208 }
282f25c9 6209 /* ... before we throw it away */
3280af22 6210 SvREFCNT_dec(PL_compcv);
b5c19bd7 6211 PL_compcv = cv;
a0d0e21e
LW		 6212 }
6213 else {
3280af22 6214 cv = PL_compcv;
44a8e56a 6215 if (name) {
6216 GvCV(gv) = cv;
eb8433b7
NC		 6217 if (PL_madskills) {
6218 if (strEQ(name, "import")) {
ad64d0ec 6219 PL_formfeed = MUTABLE_SV(cv);
06f07c2f 6220 /* diag_listed_as: SKIPME */
fea10cf6 6221 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
eb8433b7
NC		 6222 }
6223 }
44a8e56a 6224 GvCVGEN(gv) = 0;
e1a479c5 6225 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
44a8e56a 6226 }
a0d0e21e 6227 }
09330df8 6228 if (!CvGV(cv)) {
b3f91e91 6229 CvGV_set(cv, gv);
09330df8
Z		 6230 CvFILE_set_from_cop(cv, PL_curcop);
6231 CvSTASH(cv) = PL_curstash;
4c74a7df
DM		 6232 if (PL_curstash)
6233 Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
09330df8
Z		 6234 }
6235 if (attrs) {
6236 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6237 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6238 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6239 }
8990e307 6240
3fe9a6f1 6241 if (ps)
ad64d0ec 6242 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
4633a7c4 6243
13765c85 6244 if (PL_parser && PL_parser->error_count) {
c07a80fd 6245 op_free(block);
5f66b61c 6246 block = NULL;
68dc0745 6247 if (name) {
6867be6d 6248 const char *s = strrchr(name, ':');
68dc0745 6249 s = s ? s+1 : name;
6d4c2119 6250 if (strEQ(s, "BEGIN")) {
e1ec3a88 6251 const char not_safe[] =
6d4c2119 6252 "BEGIN not safe after errors--compilation aborted";
faef0170 6253 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 6254 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 6255 else {
6256 /* force display of errors found but not reported */
38a03e6e 6257 sv_catpv(ERRSV, not_safe);
be2597df 6258 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6d4c2119
CS		 6259 }
6260 }
68dc0745 6261 }
c07a80fd 6262 }
eb8433b7 6263 install_block:
beab0874
JT		 6264 if (!block)
6265 goto done;
a0d0e21e 6266
aac018bb
NC		 6267 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6268 the debugger could be able to set a breakpoint in, so signal to
6269 pp_entereval that it should not throw away any saved lines at scope
6270 exit. */
6271
fd06b02c 6272 PL_breakable_sub_gen++;
7766f137 6273 if (CvLVALUE(cv)) {
78f9721b
SM		 6274 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6275 mod(scalarseq(block), OP_LEAVESUBLV));
7e5d8ed2 6276 block->op_attached = 1;
7766f137
GS		 6277 }
6278 else {
09c2fd24
AE		 6279 /* This makes sub {}; work as expected. */
6280 if (block->op_type == OP_STUB) {
1496a290 6281 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 6282#ifdef PERL_MAD
6283 op_getmad(block,newblock,'B');
6284#else
09c2fd24 6285 op_free(block);
eb8433b7
NC		 6286#endif
6287 block = newblock;
09c2fd24 6288 }
7e5d8ed2
DM		 6289 else
6290 block->op_attached = 1;
7766f137
GS		 6291 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6292 }
6293 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6294 OpREFCNT_set(CvROOT(cv), 1);
6295 CvSTART(cv) = LINKLIST(CvROOT(cv));
6296 CvROOT(cv)->op_next = 0;
a2efc822 6297 CALL_PEEP(CvSTART(cv));
7766f137
GS		 6298
6299 /* now that optimizer has done its work, adjust pad values */
54310121 6300
dd2155a4
DM		 6301 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6302
6303 if (CvCLONE(cv)) {
beab0874
JT		 6304 assert(!CvCONST(cv));
6305 if (ps && !*ps && op_const_sv(block, cv))
6306 CvCONST_on(cv);
a0d0e21e 6307 }
79072805 6308
ed4a8a9b 6309 if (has_name) {
3280af22 6310 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
c4420975 6311 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 6312 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6313 GV_ADDMULTI, SVt_PVHV);
44a8e56a 6314 HV *hv;
b081dd7e
NC		 6315 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6316 CopFILE(PL_curcop),
6317 (long)PL_subline,
6318 (long)CopLINE(PL_curcop));
bd61b366 6319 gv_efullname3(tmpstr, gv, NULL);
04fe65b0
RGS		 6320 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6321 SvCUR(tmpstr), sv, 0);
44a8e56a 6322 hv = GvHVn(db_postponed);
f4431c56 6323 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
551405c4
AL		 6324 CV * const pcv = GvCV(db_postponed);
6325 if (pcv) {
6326 dSP;
6327 PUSHMARK(SP);
6328 XPUSHs(tmpstr);
6329 PUTBACK;
ad64d0ec 6330 call_sv(MUTABLE_SV(pcv), G_DISCARD);
551405c4 6331 }
44a8e56a 6332 }
6333 }
79072805 6334
13765c85 6335 if (name && ! (PL_parser && PL_parser->error_count))
0cd10f52 6336 process_special_blocks(name, gv, cv);
33fb7a6e 6337 }
ed094faf 6338
33fb7a6e 6339 done:
53a7735b
DM		 6340 if (PL_parser)
6341 PL_parser->copline = NOLINE;
33fb7a6e
NC		 6342 LEAVE_SCOPE(floor);
6343 return cv;
6344}
ed094faf 6345
33fb7a6e
NC		 6346STATIC void
6347S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6348 CV *const cv)
6349{
6350 const char *const colon = strrchr(fullname,':');
6351 const char *const name = colon ? colon + 1 : fullname;
6352
7918f24d
NC		 6353 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6354
33fb7a6e 6355 if (*name == 'B') {
6952d67e 6356 if (strEQ(name, "BEGIN")) {
6867be6d 6357 const I32 oldscope = PL_scopestack_ix;
28757baa 6358 ENTER;
57843af0
GS		 6359 SAVECOPFILE(&PL_compiling);
6360 SAVECOPLINE(&PL_compiling);
28757baa 6361
a58fb6f9 6362 DEBUG_x( dump_sub(gv) );
ad64d0ec 6363 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
ea2f84a3 6364 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 6365 call_list(oldscope, PL_beginav);
a6006777 6366
3280af22 6367 PL_curcop = &PL_compiling;
623e6609 6368 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 6369 LEAVE;
6370 }
33fb7a6e
NC		 6371 else
6372 return;
6373 } else {
6374 if (*name == 'E') {
6375 if strEQ(name, "END") {
a58fb6f9 6376 DEBUG_x( dump_sub(gv) );
ad64d0ec 6377 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
33fb7a6e
NC		 6378 } else
6379 return;
6380 } else if (*name == 'U') {
6381 if (strEQ(name, "UNITCHECK")) {
6382 /* It's never too late to run a unitcheck block */
ad64d0ec 6383 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
33fb7a6e
NC		 6384 }
6385 else
6386 return;
6387 } else if (*name == 'C') {
6388 if (strEQ(name, "CHECK")) {
a2a5de95
NC		 6389 if (PL_main_start)
6390 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6391 "Too late to run CHECK block");
ad64d0ec 6392 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
33fb7a6e
NC		 6393 }
6394 else
6395 return;
6396 } else if (*name == 'I') {
6397 if (strEQ(name, "INIT")) {
a2a5de95
NC		 6398 if (PL_main_start)
6399 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6400 "Too late to run INIT block");
ad64d0ec 6401 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
33fb7a6e
NC		 6402 }
6403 else
6404 return;
6405 } else
6406 return;
a58fb6f9 6407 DEBUG_x( dump_sub(gv) );
33fb7a6e 6408 GvCV(gv) = 0; /* cv has been hijacked */
79072805 6409 }
79072805
LW		 6410}
6411
954c1994
GS		 6412/*
6413=for apidoc newCONSTSUB
6414
6415Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6416eligible for inlining at compile-time.
6417
99ab892b
NC		 6418Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6419which won't be called if used as a destructor, but will suppress the overhead
6420of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6421compile time.)
6422
954c1994
GS		 6423=cut
6424*/
6425
beab0874 6426CV *
e1ec3a88 6427Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5476c433 6428{
27da23d5 6429 dVAR;
beab0874 6430 CV* cv;
cbf82dd0 6431#ifdef USE_ITHREADS
54d012c6 6432 const char *const file = CopFILE(PL_curcop);
cbf82dd0
NC		 6433#else
6434 SV *const temp_sv = CopFILESV(PL_curcop);
def18e4c 6435 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
cbf82dd0 6436#endif
5476c433 6437
11faa288 6438 ENTER;
11faa288 6439
401667e9
DM		 6440 if (IN_PERL_RUNTIME) {
6441 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6442 * an op shared between threads. Use a non-shared COP for our
6443 * dirty work */
6444 SAVEVPTR(PL_curcop);
6445 PL_curcop = &PL_compiling;
6446 }
f4dd75d9 6447 SAVECOPLINE(PL_curcop);
53a7735b 6448 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 6449
6450 SAVEHINTS();
3280af22 6451 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 6452
6453 if (stash) {
6454 SAVESPTR(PL_curstash);
6455 SAVECOPSTASH(PL_curcop);
6456 PL_curstash = stash;
05ec9bb3 6457 CopSTASH_set(PL_curcop,stash);
11faa288 6458 }
5476c433 6459
cbf82dd0
NC		 6460 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6461 and so doesn't get free()d. (It's expected to be from the C pre-
6462 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee 6463 and we need it to get freed. */
54d012c6
NC		 6464 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6465 XS_DYNAMIC_FILENAME);
beab0874
JT		 6466 CvXSUBANY(cv).any_ptr = sv;
6467 CvCONST_on(cv);
5476c433 6468
65e66c80 6469#ifdef USE_ITHREADS
02f28d44
MHM		 6470 if (stash)
6471 CopSTASH_free(PL_curcop);
65e66c80 6472#endif
11faa288 6473 LEAVE;
beab0874
JT		 6474
6475 return cv;
5476c433
JD		 6476}
6477
77004dee
NC		 6478CV *
6479Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6480 const char *const filename, const char *const proto,
6481 U32 flags)
6482{
6483 CV *cv = newXS(name, subaddr, filename);
6484
7918f24d
NC		 6485 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6486
77004dee
NC		 6487 if (flags & XS_DYNAMIC_FILENAME) {
6488 /* We need to "make arrangements" (ie cheat) to ensure that the
6489 filename lasts as long as the PVCV we just created, but also doesn't
6490 leak */
6491 STRLEN filename_len = strlen(filename);
6492 STRLEN proto_and_file_len = filename_len;
6493 char *proto_and_file;
6494 STRLEN proto_len;
6495
6496 if (proto) {
6497 proto_len = strlen(proto);
6498 proto_and_file_len += proto_len;
6499
6500 Newx(proto_and_file, proto_and_file_len + 1, char);
6501 Copy(proto, proto_and_file, proto_len, char);
6502 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6503 } else {
6504 proto_len = 0;
6505 proto_and_file = savepvn(filename, filename_len);
6506 }
6507
6508 /* This gets free()d. :-) */
ad64d0ec 6509 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
77004dee
NC		 6510 SV_HAS_TRAILING_NUL);
6511 if (proto) {
6512 /* This gives us the correct prototype, rather than one with the
6513 file name appended. */
6514 SvCUR_set(cv, proto_len);
6515 } else {
6516 SvPOK_off(cv);
6517 }
81a2b3b6 6518 CvFILE(cv) = proto_and_file + proto_len;
77004dee 6519 } else {
ad64d0ec 6520 sv_setpv(MUTABLE_SV(cv), proto);
77004dee
NC		 6521 }
6522 return cv;
6523}
6524
954c1994
GS		 6525/*
6526=for apidoc U||newXS
6527
77004dee
NC		 6528Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6529static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 6530
6531=cut
6532*/
6533
57d3b86d 6534CV *
bfed75c6 6535Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 6536{
97aff369 6537 dVAR;
666ea192
JH		 6538 GV * const gv = gv_fetchpv(name ? name :
6539 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6540 GV_ADDMULTI, SVt_PVCV);
79072805 6541 register CV *cv;
44a8e56a 6542
7918f24d
NC		 6543 PERL_ARGS_ASSERT_NEWXS;
6544
1ecdd9a8
HS		 6545 if (!subaddr)
6546 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6547
601f1833 6548 if ((cv = (name ? GvCV(gv) : NULL))) {
44a8e56a 6549 if (GvCVGEN(gv)) {
6550 /* just a cached method */
6551 SvREFCNT_dec(cv);
601f1833 6552 cv = NULL;
44a8e56a 6553 }
6554 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6555 /* already defined (or promised) */
1df70142 6556 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
66a1b24b
AL		 6557 if (ckWARN(WARN_REDEFINE)) {
6558 GV * const gvcv = CvGV(cv);
6559 if (gvcv) {
6560 HV * const stash = GvSTASH(gvcv);
6561 if (stash) {
8b38226b
AL		 6562 const char *redefined_name = HvNAME_get(stash);
6563 if ( strEQ(redefined_name,"autouse") ) {
66a1b24b 6564 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 6565 if (PL_parser && PL_parser->copline != NOLINE)
6566 CopLINE_set(PL_curcop, PL_parser->copline);
66a1b24b 6567 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 6568 CvCONST(cv) ? "Constant subroutine %s redefined"
6569 : "Subroutine %s redefined"
6570 ,name);
66a1b24b
AL		 6571 CopLINE_set(PL_curcop, oldline);
6572 }
6573 }
6574 }
a0d0e21e
LW		 6575 }
6576 SvREFCNT_dec(cv);
601f1833 6577 cv = NULL;
79072805 6578 }
79072805 6579 }
44a8e56a 6580
6581 if (cv) /* must reuse cv if autoloaded */
6582 cv_undef(cv);
a0d0e21e 6583 else {
ea726b52 6584 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
44a8e56a 6585 if (name) {
6586 GvCV(gv) = cv;
6587 GvCVGEN(gv) = 0;
e1a479c5 6588 mro_method_changed_in(GvSTASH(gv)); /* newXS */
44a8e56a 6589 }
a0d0e21e 6590 }
803f2748
DM		 6591 if (!name)
6592 CvANON_on(cv);
b3f91e91 6593 CvGV_set(cv, gv);
b195d487 6594 (void)gv_fetchfile(filename);
dd374669 6595 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 6596 an external constant string */
d04ba589 6597 CvISXSUB_on(cv);
a0d0e21e 6598 CvXSUB(cv) = subaddr;
44a8e56a 6599
33fb7a6e
NC		 6600 if (name)
6601 process_special_blocks(name, gv, cv);
44a8e56a 6602
a0d0e21e 6603 return cv;
79072805
LW		 6604}
6605
eb8433b7
NC		 6606#ifdef PERL_MAD
6607OP *
6608#else
79072805 6609void
eb8433b7 6610#endif
864dbfa3 6611Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 6612{
97aff369 6613 dVAR;
79072805 6614 register CV *cv;
eb8433b7
NC		 6615#ifdef PERL_MAD
6616 OP* pegop = newOP(OP_NULL, 0);
6617#endif
79072805 6618
0bd48802 6619 GV * const gv = o
f776e3cd 6620 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 6621 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 6622
a5f75d66 6623 GvMULTI_on(gv);
155aba94 6624 if ((cv = GvFORM(gv))) {
599cee73 6625 if (ckWARN(WARN_REDEFINE)) {
6867be6d 6626 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 6627 if (PL_parser && PL_parser->copline != NOLINE)
6628 CopLINE_set(PL_curcop, PL_parser->copline);
ee6d2783
NC		 6629 if (o) {
6630 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6631 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6632 } else {
6633 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6634 "Format STDOUT redefined");
6635 }
57843af0 6636 CopLINE_set(PL_curcop, oldline);
79072805 6637 }
8990e307 6638 SvREFCNT_dec(cv);
79072805 6639 }
3280af22 6640 cv = PL_compcv;
79072805 6641 GvFORM(gv) = cv;
b3f91e91 6642 CvGV_set(cv, gv);
a636914a 6643 CvFILE_set_from_cop(cv, PL_curcop);
79072805 6644
a0d0e21e 6645
dd2155a4 6646 pad_tidy(padtidy_FORMAT);
79072805 6647 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 6648 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6649 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 6650 CvSTART(cv) = LINKLIST(CvROOT(cv));
6651 CvROOT(cv)->op_next = 0;
a2efc822 6652 CALL_PEEP(CvSTART(cv));
eb8433b7
NC		 6653#ifdef PERL_MAD
6654 op_getmad(o,pegop,'n');
6655 op_getmad_weak(block, pegop, 'b');
6656#else
11343788 6657 op_free(o);
eb8433b7 6658#endif
53a7735b
DM		 6659 if (PL_parser)
6660 PL_parser->copline = NOLINE;
8990e307 6661 LEAVE_SCOPE(floor);
eb8433b7
NC		 6662#ifdef PERL_MAD
6663 return pegop;
6664#endif
79072805
LW		 6665}
6666
6667OP *
864dbfa3 6668Perl_newANONLIST(pTHX_ OP *o)
79072805 6669{
78c72037 6670 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 6671}
6672
6673OP *
864dbfa3 6674Perl_newANONHASH(pTHX_ OP *o)
79072805 6675{
78c72037 6676 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 6677}
6678
6679OP *
864dbfa3 6680Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 6681{
5f66b61c 6682 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 6683}
6684
6685OP *
6686Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6687{
a0d0e21e 6688 return newUNOP(OP_REFGEN, 0,
09bef843 6689 newSVOP(OP_ANONCODE, 0,
ad64d0ec 6690 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
79072805
LW		 6691}
6692
6693OP *
864dbfa3 6694Perl_oopsAV(pTHX_ OP *o)
79072805 6695{
27da23d5 6696 dVAR;
7918f24d
NC		 6697
6698 PERL_ARGS_ASSERT_OOPSAV;
6699
ed6116ce
LW		 6700 switch (o->op_type) {
6701 case OP_PADSV:
6702 o->op_type = OP_PADAV;
22c35a8c 6703 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 6704 return ref(o, OP_RV2AV);
b2ffa427 6705
ed6116ce 6706 case OP_RV2SV:
79072805 6707 o->op_type = OP_RV2AV;
22c35a8c 6708 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 6709 ref(o, OP_RV2AV);
ed6116ce
LW		 6710 break;
6711
6712 default:
9b387841 6713 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 6714 break;
6715 }
79072805
LW		 6716 return o;
6717}
6718
6719OP *
864dbfa3 6720Perl_oopsHV(pTHX_ OP *o)
79072805 6721{
27da23d5 6722 dVAR;
7918f24d
NC		 6723
6724 PERL_ARGS_ASSERT_OOPSHV;
6725
ed6116ce
LW		 6726 switch (o->op_type) {
6727 case OP_PADSV:
6728 case OP_PADAV:
6729 o->op_type = OP_PADHV;
22c35a8c 6730 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 6731 return ref(o, OP_RV2HV);
ed6116ce
LW		 6732
6733 case OP_RV2SV:
6734 case OP_RV2AV:
79072805 6735 o->op_type = OP_RV2HV;
22c35a8c 6736 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 6737 ref(o, OP_RV2HV);
ed6116ce
LW		 6738 break;
6739
6740 default:
9b387841 6741 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 6742 break;
6743 }
79072805
LW		 6744 return o;
6745}
6746
6747OP *
864dbfa3 6748Perl_newAVREF(pTHX_ OP *o)
79072805 6749{
27da23d5 6750 dVAR;
7918f24d
NC		 6751
6752 PERL_ARGS_ASSERT_NEWAVREF;
6753
ed6116ce
LW		 6754 if (o->op_type == OP_PADANY) {
6755 o->op_type = OP_PADAV;
22c35a8c 6756 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 6757 return o;
ed6116ce 6758 }
a2a5de95 6759 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
d1d15184 6760 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 6761 "Using an array as a reference is deprecated");
a1063b2d 6762 }
79072805
LW		 6763 return newUNOP(OP_RV2AV, 0, scalar(o));
6764}
6765
6766OP *
864dbfa3 6767Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 6768{
82092f1d 6769 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 6770 return newUNOP(OP_NULL, 0, o);
748a9306 6771 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 6772}
6773
6774OP *
864dbfa3 6775Perl_newHVREF(pTHX_ OP *o)
79072805 6776{
27da23d5 6777 dVAR;
7918f24d
NC		 6778
6779 PERL_ARGS_ASSERT_NEWHVREF;
6780
ed6116ce
LW		 6781 if (o->op_type == OP_PADANY) {
6782 o->op_type = OP_PADHV;
22c35a8c 6783 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 6784 return o;
ed6116ce 6785 }
a2a5de95 6786 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
d1d15184 6787 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 6788 "Using a hash as a reference is deprecated");
a1063b2d 6789 }
79072805
LW		 6790 return newUNOP(OP_RV2HV, 0, scalar(o));
6791}
6792
6793OP *
864dbfa3 6794Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 6795{
c07a80fd 6796 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 6797}
6798
6799OP *
864dbfa3 6800Perl_newSVREF(pTHX_ OP *o)
79072805 6801{
27da23d5 6802 dVAR;
7918f24d
NC		 6803
6804 PERL_ARGS_ASSERT_NEWSVREF;
6805
ed6116ce
LW		 6806 if (o->op_type == OP_PADANY) {
6807 o->op_type = OP_PADSV;
22c35a8c 6808 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 6809 return o;
ed6116ce 6810 }
79072805
LW		 6811 return newUNOP(OP_RV2SV, 0, scalar(o));
6812}
6813
61b743bb
DM		 6814/* Check routines. See the comments at the top of this file for details
6815 * on when these are called */
79072805
LW		 6816
6817OP *
cea2e8a9 6818Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 6819{
7918f24d
NC		 6820 PERL_ARGS_ASSERT_CK_ANONCODE;
6821
dd2155a4 6822 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
eb8433b7 6823 if (!PL_madskills)
1d866c12 6824 cSVOPo->op_sv = NULL;
5dc0d613 6825 return o;
5f05dabc 6826}
6827
6828OP *
cea2e8a9 6829Perl_ck_bitop(pTHX_ OP *o)
55497cff 6830{
97aff369 6831 dVAR;
7918f24d
NC		 6832
6833 PERL_ARGS_ASSERT_CK_BITOP;
6834
276b2a0c
RGS		 6835#define OP_IS_NUMCOMPARE(op) \
6836 ((op) == OP_LT || (op) == OP_I_LT || \
6837 (op) == OP_GT || (op) == OP_I_GT || \
6838 (op) == OP_LE || (op) == OP_I_LE || \
6839 (op) == OP_GE || (op) == OP_I_GE || \
6840 (op) == OP_EQ || (op) == OP_I_EQ || \
6841 (op) == OP_NE || (op) == OP_I_NE || \
6842 (op) == OP_NCMP || (op) == OP_I_NCMP)
d5ec2987 6843 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 6844 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6845 && (o->op_type == OP_BIT_OR
6846 || o->op_type == OP_BIT_AND
6847 || o->op_type == OP_BIT_XOR))
276b2a0c 6848 {
1df70142
AL		 6849 const OP * const left = cBINOPo->op_first;
6850 const OP * const right = left->op_sibling;
96a925ab
YST		 6851 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6852 (left->op_flags & OPf_PARENS) == 0) ||
6853 (OP_IS_NUMCOMPARE(right->op_type) &&
6854 (right->op_flags & OPf_PARENS) == 0))
a2a5de95
NC		 6855 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6856 "Possible precedence problem on bitwise %c operator",
6857 o->op_type == OP_BIT_OR ? '|'
6858 : o->op_type == OP_BIT_AND ? '&' : '^'
6859 );
276b2a0c 6860 }
5dc0d613 6861 return o;
55497cff 6862}
6863
6864OP *
cea2e8a9 6865Perl_ck_concat(pTHX_ OP *o)
79072805 6866{
0bd48802 6867 const OP * const kid = cUNOPo->op_first;
7918f24d
NC		 6868
6869 PERL_ARGS_ASSERT_CK_CONCAT;
96a5add6 6870 PERL_UNUSED_CONTEXT;
7918f24d 6871
df91b2c5
AE		 6872 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6873 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 6874 o->op_flags |= OPf_STACKED;
11343788 6875 return o;
79072805
LW		 6876}
6877
6878OP *
cea2e8a9 6879Perl_ck_spair(pTHX_ OP *o)
79072805 6880{
27da23d5 6881 dVAR;
7918f24d
NC		 6882
6883 PERL_ARGS_ASSERT_CK_SPAIR;
6884
11343788 6885 if (o->op_flags & OPf_KIDS) {
79072805 6886 OP* newop;
a0d0e21e 6887 OP* kid;
6867be6d 6888 const OPCODE type = o->op_type;
5dc0d613 6889 o = modkids(ck_fun(o), type);
11343788 6890 kid = cUNOPo->op_first;
a0d0e21e 6891 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 6892 if (newop) {
6893 const OPCODE type = newop->op_type;
6894 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6895 type == OP_PADAV || type == OP_PADHV ||
6896 type == OP_RV2AV || type == OP_RV2HV)
6897 return o;
a0d0e21e 6898 }
eb8433b7
NC		 6899#ifdef PERL_MAD
6900 op_getmad(kUNOP->op_first,newop,'K');
6901#else
a0d0e21e 6902 op_free(kUNOP->op_first);
eb8433b7 6903#endif
a0d0e21e
LW		 6904 kUNOP->op_first = newop;
6905 }
22c35a8c 6906 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 6907 return ck_fun(o);
a0d0e21e
LW		 6908}
6909
6910OP *
cea2e8a9 6911Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 6912{
7918f24d
NC		 6913 PERL_ARGS_ASSERT_CK_DELETE;
6914
11343788 6915 o = ck_fun(o);
5dc0d613 6916 o->op_private = 0;
11343788 6917 if (o->op_flags & OPf_KIDS) {
551405c4 6918 OP * const kid = cUNOPo->op_first;
01020589
GS		 6919 switch (kid->op_type) {
6920 case OP_ASLICE:
6921 o->op_flags |= OPf_SPECIAL;
6922 /* FALL THROUGH */
6923 case OP_HSLICE:
5dc0d613 6924 o->op_private |= OPpSLICE;
01020589
GS		 6925 break;
6926 case OP_AELEM:
6927 o->op_flags |= OPf_SPECIAL;
6928 /* FALL THROUGH */
6929 case OP_HELEM:
6930 break;
6931 default:
6932 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 6933 OP_DESC(o));
01020589 6934 }
7332a6c4
VP		 6935 if (kid->op_private & OPpLVAL_INTRO)
6936 o->op_private |= OPpLVAL_INTRO;
93c66552 6937 op_null(kid);
79072805 6938 }
11343788 6939 return o;
79072805
LW		 6940}
6941
6942OP *
96e176bf
CL		 6943Perl_ck_die(pTHX_ OP *o)
6944{
7918f24d
NC		 6945 PERL_ARGS_ASSERT_CK_DIE;
6946
96e176bf
CL		 6947#ifdef VMS
6948 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6949#endif
6950 return ck_fun(o);
6951}
6952
6953OP *
cea2e8a9 6954Perl_ck_eof(pTHX_ OP *o)
79072805 6955{
97aff369 6956 dVAR;
79072805 6957
7918f24d
NC		 6958 PERL_ARGS_ASSERT_CK_EOF;
6959
11343788
MB		 6960 if (o->op_flags & OPf_KIDS) {
6961 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 6962 OP * const newop
6963 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 6964#ifdef PERL_MAD
6965 op_getmad(o,newop,'O');
6966#else
11343788 6967 op_free(o);
eb8433b7
NC		 6968#endif
6969 o = newop;
8990e307 6970 }
11343788 6971 return ck_fun(o);
79072805 6972 }
11343788 6973 return o;
79072805
LW		 6974}
6975
6976OP *
cea2e8a9 6977Perl_ck_eval(pTHX_ OP *o)
79072805 6978{
27da23d5 6979 dVAR;
7918f24d
NC		 6980
6981 PERL_ARGS_ASSERT_CK_EVAL;
6982
3280af22 6983 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6984 if (o->op_flags & OPf_KIDS) {
46c461b5 6985 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 6986
93a17b20 6987 if (!kid) {
11343788 6988 o->op_flags &= ~OPf_KIDS;
93c66552 6989 op_null(o);
79072805 6990 }
b14574b4 6991 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 6992 LOGOP *enter;
eb8433b7 6993#ifdef PERL_MAD
1d866c12 6994 OP* const oldo = o;
eb8433b7 6995#endif
79072805 6996
11343788 6997 cUNOPo->op_first = 0;
eb8433b7 6998#ifndef PERL_MAD
11343788 6999 op_free(o);
eb8433b7 7000#endif
79072805 7001
b7dc083c 7002 NewOp(1101, enter, 1, LOGOP);
79072805 7003 enter->op_type = OP_ENTERTRY;
22c35a8c 7004 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 7005 enter->op_private = 0;
7006
7007 /* establish postfix order */
7008 enter->op_next = (OP*)enter;
7009
11343788
MB		 7010 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7011 o->op_type = OP_LEAVETRY;
22c35a8c 7012 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 7013 enter->op_other = o;
eb8433b7 7014 op_getmad(oldo,o,'O');
11343788 7015 return o;
79072805 7016 }
b5c19bd7 7017 else {
473986ff 7018 scalar((OP*)kid);
b5c19bd7
DM		 7019 PL_cv_has_eval = 1;
7020 }
79072805
LW		 7021 }
7022 else {
eb8433b7 7023#ifdef PERL_MAD
1d866c12 7024 OP* const oldo = o;
eb8433b7 7025#else
11343788 7026 op_free(o);
eb8433b7 7027#endif
54b9620d 7028 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
eb8433b7 7029 op_getmad(oldo,o,'O');
79072805 7030 }
3280af22 7031 o->op_targ = (PADOFFSET)PL_hints;
7168684c 7032 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
996c9baa
VP		 7033 /* Store a copy of %^H that pp_entereval can pick up. */
7034 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
defdfed5 7035 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
0d863452
RH		 7036 cUNOPo->op_first->op_sibling = hhop;
7037 o->op_private |= OPpEVAL_HAS_HH;
7038 }
11343788 7039 return o;
79072805
LW		 7040}
7041
7042OP *
d98f61e7
GS		 7043Perl_ck_exit(pTHX_ OP *o)
7044{
7918f24d
NC		 7045 PERL_ARGS_ASSERT_CK_EXIT;
7046
d98f61e7 7047#ifdef VMS
551405c4 7048 HV * const table = GvHV(PL_hintgv);
d98f61e7 7049 if (table) {
a4fc7abc 7050 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 7051 if (svp && *svp && SvTRUE(*svp))
7052 o->op_private |= OPpEXIT_VMSISH;
7053 }
96e176bf 7054 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 7055#endif
7056 return ck_fun(o);
7057}
7058
7059OP *
cea2e8a9 7060Perl_ck_exec(pTHX_ OP *o)
79072805 7061{
7918f24d
NC		 7062 PERL_ARGS_ASSERT_CK_EXEC;
7063
11343788 7064 if (o->op_flags & OPf_STACKED) {
6867be6d 7065 OP *kid;
11343788
MB		 7066 o = ck_fun(o);
7067 kid = cUNOPo->op_first->op_sibling;
8990e307 7068 if (kid->op_type == OP_RV2GV)
93c66552 7069 op_null(kid);
79072805 7070 }
463ee0b2 7071 else
11343788
MB		 7072 o = listkids(o);
7073 return o;
79072805
LW		 7074}
7075
7076OP *
cea2e8a9 7077Perl_ck_exists(pTHX_ OP *o)
5f05dabc 7078{
97aff369 7079 dVAR;
7918f24d
NC		 7080
7081 PERL_ARGS_ASSERT_CK_EXISTS;
7082
5196be3e
MB		 7083 o = ck_fun(o);
7084 if (o->op_flags & OPf_KIDS) {
46c461b5 7085 OP * const kid = cUNOPo->op_first;
afebc493
GS		 7086 if (kid->op_type == OP_ENTERSUB) {
7087 (void) ref(kid, o->op_type);
13765c85
DM		 7088 if (kid->op_type != OP_RV2CV
7089 && !(PL_parser && PL_parser->error_count))
afebc493 7090 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 7091 OP_DESC(o));
afebc493
GS		 7092 o->op_private |= OPpEXISTS_SUB;
7093 }
7094 else if (kid->op_type == OP_AELEM)
01020589
GS		 7095 o->op_flags |= OPf_SPECIAL;
7096 else if (kid->op_type != OP_HELEM)
b0fdf69e 7097 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
53e06cf0 7098 OP_DESC(o));
93c66552 7099 op_null(kid);
5f05dabc 7100 }
5196be3e 7101 return o;
5f05dabc 7102}
7103
79072805 7104OP *
cea2e8a9 7105Perl_ck_rvconst(pTHX_ register OP *o)
79072805 7106{
27da23d5 7107 dVAR;
0bd48802 7108 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 7109
7918f24d
NC		 7110 PERL_ARGS_ASSERT_CK_RVCONST;
7111
3280af22 7112 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 7113 if (o->op_type == OP_RV2CV)
7114 o->op_private &= ~1;
7115
79072805 7116 if (kid->op_type == OP_CONST) {
44a8e56a 7117 int iscv;
7118 GV *gv;
504618e9 7119 SV * const kidsv = kid->op_sv;
44a8e56a 7120
779c5bc9
GS		 7121 /* Is it a constant from cv_const_sv()? */
7122 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 7123 SV * const rsv = SvRV(kidsv);
42d0e0b7 7124 const svtype type = SvTYPE(rsv);
bd61b366 7125 const char *badtype = NULL;
779c5bc9
GS		 7126
7127 switch (o->op_type) {
7128 case OP_RV2SV:
42d0e0b7 7129 if (type > SVt_PVMG)
779c5bc9
GS		 7130 badtype = "a SCALAR";
7131 break;
7132 case OP_RV2AV:
42d0e0b7 7133 if (type != SVt_PVAV)
779c5bc9
GS		 7134 badtype = "an ARRAY";
7135 break;
7136 case OP_RV2HV:
42d0e0b7 7137 if (type != SVt_PVHV)
779c5bc9 7138 badtype = "a HASH";
779c5bc9
GS		 7139 break;
7140 case OP_RV2CV:
42d0e0b7 7141 if (type != SVt_PVCV)
779c5bc9
GS		 7142 badtype = "a CODE";
7143 break;
7144 }
7145 if (badtype)
cea2e8a9 7146 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 7147 return o;
7148 }
ce10b5d1 7149 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 7150 const char *badthing;
5dc0d613 7151 switch (o->op_type) {
44a8e56a 7152 case OP_RV2SV:
7153 badthing = "a SCALAR";
7154 break;
7155 case OP_RV2AV:
7156 badthing = "an ARRAY";
7157 break;
7158 case OP_RV2HV:
7159 badthing = "a HASH";
7160 break;
5f66b61c
AL		 7161 default:
7162 badthing = NULL;
7163 break;
44a8e56a 7164 }
7165 if (badthing)
1c846c1f 7166 Perl_croak(aTHX_
95b63a38 7167 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 7168 SVfARG(kidsv), badthing);
44a8e56a 7169 }
93233ece
CS		 7170 /*
7171 * This is a little tricky. We only want to add the symbol if we
7172 * didn't add it in the lexer. Otherwise we get duplicate strict
7173 * warnings. But if we didn't add it in the lexer, we must at
7174 * least pretend like we wanted to add it even if it existed before,
7175 * or we get possible typo warnings. OPpCONST_ENTERED says
7176 * whether the lexer already added THIS instance of this symbol.
7177 */
5196be3e 7178 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 7179 do {
7a5fd60d 7180 gv = gv_fetchsv(kidsv,
748a9306 7181 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 7182 iscv
7183 ? SVt_PVCV
11343788 7184 : o->op_type == OP_RV2SV
a0d0e21e 7185 ? SVt_PV
11343788 7186 : o->op_type == OP_RV2AV
a0d0e21e 7187 ? SVt_PVAV
11343788 7188 : o->op_type == OP_RV2HV
a0d0e21e
LW		 7189 ? SVt_PVHV
7190 : SVt_PVGV);
93233ece
CS		 7191 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7192 if (gv) {
7193 kid->op_type = OP_GV;
7194 SvREFCNT_dec(kid->op_sv);
350de78d 7195#ifdef USE_ITHREADS
638eceb6 7196 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 7197 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 7198 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 7199 GvIN_PAD_on(gv);
ad64d0ec 7200 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
350de78d 7201#else
b37c2d43 7202 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 7203#endif
23f1ca44 7204 kid->op_private = 0;
76cd736e 7205 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 7206 }
79072805 7207 }
11343788 7208 return o;
79072805
LW		 7209}
7210
7211OP *
cea2e8a9 7212Perl_ck_ftst(pTHX_ OP *o)
79072805 7213{
27da23d5 7214 dVAR;
6867be6d 7215 const I32 type = o->op_type;
79072805 7216
7918f24d
NC		 7217 PERL_ARGS_ASSERT_CK_FTST;
7218
d0dca557 7219 if (o->op_flags & OPf_REF) {
6f207bd3 7220 NOOP;
d0dca557
JD		 7221 }
7222 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 7223 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 7224 const OPCODE kidtype = kid->op_type;
79072805 7225
1496a290 7226 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 7227 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 7228 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 7229#ifdef PERL_MAD
7230 op_getmad(o,newop,'O');
7231#else
11343788 7232 op_free(o);
eb8433b7 7233#endif
1d866c12 7234 return newop;
79072805 7235 }
6ecf81d6 7236 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
1af34c76 7237 o->op_private |= OPpFT_ACCESS;
1496a290
AL		 7238 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
7239 && kidtype != OP_STAT && kidtype != OP_LSTAT)
fbb0b3b3 7240 o->op_private |= OPpFT_STACKED;
79072805
LW		 7241 }
7242 else {
eb8433b7 7243#ifdef PERL_MAD
1d866c12 7244 OP* const oldo = o;
eb8433b7 7245#else
11343788 7246 op_free(o);
eb8433b7 7247#endif
79072805 7248 if (type == OP_FTTTY)
8fde6460 7249 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 7250 else
d0dca557 7251 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 7252 op_getmad(oldo,o,'O');
79072805 7253 }
11343788 7254 return o;
79072805
LW		 7255}
7256
7257OP *
cea2e8a9 7258Perl_ck_fun(pTHX_ OP *o)
79072805 7259{
97aff369 7260 dVAR;
6867be6d 7261 const int type = o->op_type;
22c35a8c 7262 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 7263
7918f24d
NC		 7264 PERL_ARGS_ASSERT_CK_FUN;
7265
11343788 7266 if (o->op_flags & OPf_STACKED) {
79072805
LW		 7267 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7268 oa &= ~OA_OPTIONAL;
7269 else
11343788 7270 return no_fh_allowed(o);
79072805
LW		 7271 }
7272
11343788 7273 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 7274 OP **tokid = &cLISTOPo->op_first;
7275 register OP *kid = cLISTOPo->op_first;
7276 OP *sibl;
7277 I32 numargs = 0;
7278
8990e307 7279 if (kid->op_type == OP_PUSHMARK ||
155aba94 7280 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 7281 {
79072805
LW		 7282 tokid = &kid->op_sibling;
7283 kid = kid->op_sibling;
7284 }
22c35a8c 7285 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 7286 *tokid = kid = newDEFSVOP();
79072805
LW		 7287
7288 while (oa && kid) {
7289 numargs++;
7290 sibl = kid->op_sibling;
eb8433b7
NC		 7291#ifdef PERL_MAD
7292 if (!sibl && kid->op_type == OP_STUB) {
7293 numargs--;
7294 break;
7295 }
7296#endif
79072805
LW		 7297 switch (oa & 7) {
7298 case OA_SCALAR:
62c18ce2
GS		 7299 /* list seen where single (scalar) arg expected? */
7300 if (numargs == 1 && !(oa >> 4)
7301 && kid->op_type == OP_LIST && type != OP_SCALAR)
7302 {
7303 return too_many_arguments(o,PL_op_desc[type]);
7304 }
79072805
LW		 7305 scalar(kid);
7306 break;
7307 case OA_LIST:
7308 if (oa < 16) {
7309 kid = 0;
7310 continue;
7311 }
7312 else
7313 list(kid);
7314 break;
7315 case OA_AVREF:
936edb8b 7316 if ((type == OP_PUSH || type == OP_UNSHIFT)
a2a5de95
NC		 7317 && !kid->op_sibling)
7318 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7319 "Useless use of %s with no values",
7320 PL_op_desc[type]);
b2ffa427 7321
79072805 7322 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 7323 (kid->op_private & OPpCONST_BARE))
7324 {
551405c4 7325 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 7326 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
d1d15184 7327 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 7328 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7329 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 7330#ifdef PERL_MAD
7331 op_getmad(kid,newop,'K');
7332#else
79072805 7333 op_free(kid);
eb8433b7 7334#endif
79072805
LW		 7335 kid = newop;
7336 kid->op_sibling = sibl;
7337 *tokid = kid;
7338 }
8990e307 7339 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 7340 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 7341 mod(kid, type);
79072805
LW		 7342 break;
7343 case OA_HVREF:
7344 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 7345 (kid->op_private & OPpCONST_BARE))
7346 {
551405c4 7347 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 7348 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
d1d15184 7349 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 7350 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7351 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 7352#ifdef PERL_MAD
7353 op_getmad(kid,newop,'K');
7354#else
79072805 7355 op_free(kid);
eb8433b7 7356#endif
79072805
LW		 7357 kid = newop;
7358 kid->op_sibling = sibl;
7359 *tokid = kid;
7360 }
8990e307 7361 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 7362 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 7363 mod(kid, type);
79072805
LW		 7364 break;
7365 case OA_CVREF:
7366 {
551405c4 7367 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 7368 kid->op_sibling = 0;
7369 linklist(kid);
7370 newop->op_next = newop;
7371 kid = newop;
7372 kid->op_sibling = sibl;
7373 *tokid = kid;
7374 }
7375 break;
7376 case OA_FILEREF:
c340be78 7377 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 7378 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 7379 (kid->op_private & OPpCONST_BARE))
7380 {
0bd48802 7381 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 7382 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 7383 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 7384 kid == cLISTOPo->op_last)
364daeac 7385 cLISTOPo->op_last = newop;
eb8433b7
NC		 7386#ifdef PERL_MAD
7387 op_getmad(kid,newop,'K');
7388#else
79072805 7389 op_free(kid);
eb8433b7 7390#endif
79072805
LW		 7391 kid = newop;
7392 }
1ea32a52
GS		 7393 else if (kid->op_type == OP_READLINE) {
7394 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 7395 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 7396 }
79072805 7397 else {
35cd451c 7398 I32 flags = OPf_SPECIAL;
a6c40364 7399 I32 priv = 0;
2c8ac474
GS		 7400 PADOFFSET targ = 0;
7401
35cd451c 7402 /* is this op a FH constructor? */
853846ea 7403 if (is_handle_constructor(o,numargs)) {
bd61b366 7404 const char *name = NULL;
dd2155a4 7405 STRLEN len = 0;
2c8ac474
GS		 7406
7407 flags = 0;
7408 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 7409 * need to "prove" flag does not mean something
7410 * else already - NI-S 1999/05/07
2c8ac474
GS		 7411 */
7412 priv = OPpDEREF;
7413 if (kid->op_type == OP_PADSV) {
f8503592
NC		 7414 SV *const namesv
7415 = PAD_COMPNAME_SV(kid->op_targ);
7416 name = SvPV_const(namesv, len);
2c8ac474
GS		 7417 }
7418 else if (kid->op_type == OP_RV2SV
7419 && kUNOP->op_first->op_type == OP_GV)
7420 {
0bd48802 7421 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 7422 name = GvNAME(gv);
7423 len = GvNAMELEN(gv);
7424 }
afd1915d
GS		 7425 else if (kid->op_type == OP_AELEM
7426 || kid->op_type == OP_HELEM)
7427 {
735fec84 7428 OP *firstop;
551405c4 7429 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 7430 name = NULL;
551405c4 7431 if (op) {
a0714e2c 7432 SV *tmpstr = NULL;
551405c4 7433 const char * const a =
666ea192
JH		 7434 kid->op_type == OP_AELEM ?
7435 "[]" : "{}";
0c4b0a3f
JH		 7436 if (((op->op_type == OP_RV2AV) ||
7437 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 7438 (firstop = ((UNOP*)op)->op_first) &&
7439 (firstop->op_type == OP_GV)) {
0c4b0a3f 7440 /* packagevar $a[] or $h{} */
735fec84 7441 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 7442 if (gv)
7443 tmpstr =
7444 Perl_newSVpvf(aTHX_
7445 "%s%c...%c",
7446 GvNAME(gv),
7447 a[0], a[1]);
7448 }
7449 else if (op->op_type == OP_PADAV
7450 || op->op_type == OP_PADHV) {
7451 /* lexicalvar $a[] or $h{} */
551405c4 7452 const char * const padname =
0c4b0a3f
JH		 7453 PAD_COMPNAME_PV(op->op_targ);
7454 if (padname)
7455 tmpstr =
7456 Perl_newSVpvf(aTHX_
7457 "%s%c...%c",
7458 padname + 1,
7459 a[0], a[1]);
0c4b0a3f
JH		 7460 }
7461 if (tmpstr) {
93524f2b 7462 name = SvPV_const(tmpstr, len);
0c4b0a3f
JH		 7463 sv_2mortal(tmpstr);
7464 }
7465 }
7466 if (!name) {
7467 name = "__ANONIO__";
7468 len = 10;
7469 }
7470 mod(kid, type);
afd1915d 7471 }
2c8ac474
GS		 7472 if (name) {
7473 SV *namesv;
7474 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 7475 namesv = PAD_SVl(targ);
862a34c6 7476 SvUPGRADE(namesv, SVt_PV);
2c8ac474 7477 if (*name != '$')
76f68e9b 7478 sv_setpvs(namesv, "$");
2c8ac474
GS		 7479 sv_catpvn(namesv, name, len);
7480 }
853846ea 7481 }
79072805 7482 kid->op_sibling = 0;
35cd451c 7483 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 7484 kid->op_targ = targ;
7485 kid->op_private |= priv;
79072805
LW		 7486 }
7487 kid->op_sibling = sibl;
7488 *tokid = kid;
7489 }
7490 scalar(kid);
7491 break;
7492 case OA_SCALARREF:
a0d0e21e 7493 mod(scalar(kid), type);
79072805
LW		 7494 break;
7495 }
7496 oa >>= 4;
7497 tokid = &kid->op_sibling;
7498 kid = kid->op_sibling;
7499 }
eb8433b7
NC		 7500#ifdef PERL_MAD
7501 if (kid && kid->op_type != OP_STUB)
7502 return too_many_arguments(o,OP_DESC(o));
7503 o->op_private |= numargs;
7504#else
7505 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 7506 o->op_private |= numargs;
79072805 7507 if (kid)
53e06cf0 7508 return too_many_arguments(o,OP_DESC(o));
eb8433b7 7509#endif
11343788 7510 listkids(o);
79072805 7511 }
22c35a8c 7512 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 7513#ifdef PERL_MAD
c7fe699d 7514 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 7515 op_getmad(o,newop,'O');
c7fe699d 7516 return newop;
c56915e3 7517#else
c7fe699d 7518 /* Ordering of these two is important to keep f_map.t passing. */
11343788 7519 op_free(o);
c7fe699d 7520 return newUNOP(type, 0, newDEFSVOP());
c56915e3 7521#endif
a0d0e21e
LW		 7522 }
7523
79072805
LW		 7524 if (oa) {
7525 while (oa & OA_OPTIONAL)
7526 oa >>= 4;
7527 if (oa && oa != OA_LIST)
53e06cf0 7528 return too_few_arguments(o,OP_DESC(o));
79072805 7529 }
11343788 7530 return o;
79072805
LW		 7531}
7532
7533OP *
cea2e8a9 7534Perl_ck_glob(pTHX_ OP *o)
79072805 7535{
27da23d5 7536 dVAR;
fb73857a 7537 GV *gv;
7538
7918f24d
NC		 7539 PERL_ARGS_ASSERT_CK_GLOB;
7540
649da076 7541 o = ck_fun(o);
1f2bfc8a 7542 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 7543 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 7544
fafc274c 7545 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 7546 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7547 {
5c1737d1 7548 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 7549 }
b1cb66bf 7550
52bb0670 7551#if !defined(PERL_EXTERNAL_GLOB)
72b16652 7552 /* XXX this can be tightened up and made more failsafe. */
f444d496 7553 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 7554 GV *glob_gv;
72b16652 7555 ENTER;
00ca71c1 7556 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
a0714e2c 7557 newSVpvs("File::Glob"), NULL, NULL, NULL);
4984aa34
FC		 7558 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7559 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7560 GvCV(gv) = GvCV(glob_gv);
7561 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7562 GvIMPORTED_CV_on(gv);
7563 }
72b16652
GS		 7564 LEAVE;
7565 }
52bb0670 7566#endif /* PERL_EXTERNAL_GLOB */
72b16652 7567
b9f751c0 7568 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 7569 append_elem(OP_GLOB, o,
80252599 7570 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 7571 o->op_type = OP_LIST;
22c35a8c 7572 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 7573 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 7574 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 7575 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 7576 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 7577 append_elem(OP_LIST, o,
1f2bfc8a
MB		 7578 scalar(newUNOP(OP_RV2CV, 0,
7579 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 7580 o = newUNOP(OP_NULL, 0, ck_subr(o));
7581 o->op_targ = OP_GLOB; /* hint at what it used to be */
7582 return o;
b1cb66bf 7583 }
7584 gv = newGVgen("main");
a0d0e21e 7585 gv_IOadd(gv);
11343788
MB		 7586 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7587 scalarkids(o);
649da076 7588 return o;
79072805
LW		 7589}
7590
7591OP *
cea2e8a9 7592Perl_ck_grep(pTHX_ OP *o)
79072805 7593{
27da23d5 7594 dVAR;
03ca120d 7595 LOGOP *gwop = NULL;
79072805 7596 OP *kid;
6867be6d 7597 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 7598 PADOFFSET offset;
79072805 7599
7918f24d
NC		 7600 PERL_ARGS_ASSERT_CK_GREP;
7601
22c35a8c 7602 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 7603 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 7604
11343788 7605 if (o->op_flags & OPf_STACKED) {
a0d0e21e 7606 OP* k;
11343788 7607 o = ck_sort(o);
f6435df3
GG		 7608 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7609 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7610 return no_fh_allowed(o);
7611 for (k = kid; k; k = k->op_next) {
a0d0e21e
LW		 7612 kid = k;
7613 }
03ca120d 7614 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 7615 kid->op_next = (OP*)gwop;
11343788 7616 o->op_flags &= ~OPf_STACKED;
93a17b20 7617 }
11343788 7618 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 7619 if (type == OP_MAPWHILE)
7620 list(kid);
7621 else
7622 scalar(kid);
11343788 7623 o = ck_fun(o);
13765c85 7624 if (PL_parser && PL_parser->error_count)
11343788 7625 return o;
aeea060c 7626 kid = cLISTOPo->op_first->op_sibling;
79072805 7627 if (kid->op_type != OP_NULL)
cea2e8a9 7628 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 7629 kid = kUNOP->op_first;
7630
03ca120d
MHM		 7631 if (!gwop)
7632 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 7633 gwop->op_type = type;
22c35a8c 7634 gwop->op_ppaddr = PL_ppaddr[type];
11343788 7635 gwop->op_first = listkids(o);
79072805 7636 gwop->op_flags |= OPf_KIDS;
79072805 7637 gwop->op_other = LINKLIST(kid);
79072805 7638 kid->op_next = (OP*)gwop;
f8f98e0a 7639 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
00b1698f 7640 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 7641 o->op_private = gwop->op_private = 0;
7642 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7643 }
7644 else {
7645 o->op_private = gwop->op_private = OPpGREP_LEX;
7646 gwop->op_targ = o->op_targ = offset;
7647 }
79072805 7648
11343788 7649 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 7650 if (!kid || !kid->op_sibling)
53e06cf0 7651 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 7652 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7653 mod(kid, OP_GREPSTART);
7654
79072805
LW		 7655 return (OP*)gwop;
7656}
7657
7658OP *
cea2e8a9 7659Perl_ck_index(pTHX_ OP *o)
79072805 7660{
7918f24d
NC		 7661 PERL_ARGS_ASSERT_CK_INDEX;
7662
11343788
MB		 7663 if (o->op_flags & OPf_KIDS) {
7664 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 7665 if (kid)
7666 kid = kid->op_sibling; /* get past "big" */
79072805 7667 if (kid && kid->op_type == OP_CONST)
2779dcf1 7668 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 7669 }
11343788 7670 return ck_fun(o);
79072805
LW		 7671}
7672
7673OP *
cea2e8a9 7674Perl_ck_lfun(pTHX_ OP *o)
79072805 7675{
6867be6d 7676 const OPCODE type = o->op_type;
7918f24d
NC		 7677
7678 PERL_ARGS_ASSERT_CK_LFUN;
7679
5dc0d613 7680 return modkids(ck_fun(o), type);
79072805
LW		 7681}
7682
7683OP *
cea2e8a9 7684Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 7685{
7918f24d
NC		 7686 PERL_ARGS_ASSERT_CK_DEFINED;
7687
a2a5de95 7688 if ((o->op_flags & OPf_KIDS)) {
d0334bed
GS		 7689 switch (cUNOPo->op_first->op_type) {
7690 case OP_RV2AV:
a8739d98
JH		 7691 /* This is needed for
7692 if (defined %stash::)
7693 to work. Do not break Tk.
7694 */
1c846c1f 7695 break; /* Globals via GV can be undef */
d0334bed
GS		 7696 case OP_PADAV:
7697 case OP_AASSIGN: /* Is this a good idea? */
d1d15184 7698 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7699 "defined(@array) is deprecated");
d1d15184 7700 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7701 "\t(Maybe you should just omit the defined()?)\n");
69794302 7702 break;
d0334bed
GS		 7703 case OP_RV2HV:
7704 case OP_PADHV:
d1d15184 7705 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7706 "defined(%%hash) is deprecated");
d1d15184 7707 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7708 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 7709 break;
7710 default:
7711 /* no warning */
7712 break;
7713 }
69794302
MJD		 7714 }
7715 return ck_rfun(o);
7716}
7717
7718OP *
e4b7ebf3
RGS		 7719Perl_ck_readline(pTHX_ OP *o)
7720{
7918f24d
NC		 7721 PERL_ARGS_ASSERT_CK_READLINE;
7722
e4b7ebf3
RGS		 7723 if (!(o->op_flags & OPf_KIDS)) {
7724 OP * const newop
7725 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7726#ifdef PERL_MAD
7727 op_getmad(o,newop,'O');
7728#else
7729 op_free(o);
7730#endif
7731 return newop;
7732 }
7733 return o;
7734}
7735
7736OP *
cea2e8a9 7737Perl_ck_rfun(pTHX_ OP *o)
8990e307 7738{
6867be6d 7739 const OPCODE type = o->op_type;
7918f24d
NC		 7740
7741 PERL_ARGS_ASSERT_CK_RFUN;
7742
5dc0d613 7743 return refkids(ck_fun(o), type);
8990e307
LW		 7744}
7745
7746OP *
cea2e8a9 7747Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 7748{
7749 register OP *kid;
aeea060c 7750
7918f24d
NC		 7751 PERL_ARGS_ASSERT_CK_LISTIOB;
7752
11343788 7753 kid = cLISTOPo->op_first;
79072805 7754 if (!kid) {
11343788
MB		 7755 o = force_list(o);
7756 kid = cLISTOPo->op_first;
79072805
LW		 7757 }
7758 if (kid->op_type == OP_PUSHMARK)
7759 kid = kid->op_sibling;
11343788 7760 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 7761 kid = kid->op_sibling;
7762 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7763 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 7764 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 7765 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 7766 cLISTOPo->op_first->op_sibling = kid;
7767 cLISTOPo->op_last = kid;
79072805
LW		 7768 kid = kid->op_sibling;
7769 }
7770 }
b2ffa427 7771
79072805 7772 if (!kid)
54b9620d 7773 append_elem(o->op_type, o, newDEFSVOP());
79072805 7774
2de3dbcc 7775 return listkids(o);
bbce6d69 7776}
7777
7778OP *
0d863452
RH		 7779Perl_ck_smartmatch(pTHX_ OP *o)
7780{
97aff369 7781 dVAR;
a4e74480 7782 PERL_ARGS_ASSERT_CK_SMARTMATCH;
0d863452
RH		 7783 if (0 == (o->op_flags & OPf_SPECIAL)) {
7784 OP *first = cBINOPo->op_first;
7785 OP *second = first->op_sibling;
7786
7787 /* Implicitly take a reference to an array or hash */
5f66b61c 7788 first->op_sibling = NULL;
0d863452
RH		 7789 first = cBINOPo->op_first = ref_array_or_hash(first);
7790 second = first->op_sibling = ref_array_or_hash(second);
7791
7792 /* Implicitly take a reference to a regular expression */
7793 if (first->op_type == OP_MATCH) {
7794 first->op_type = OP_QR;
7795 first->op_ppaddr = PL_ppaddr[OP_QR];
7796 }
7797 if (second->op_type == OP_MATCH) {
7798 second->op_type = OP_QR;
7799 second->op_ppaddr = PL_ppaddr[OP_QR];
7800 }
7801 }
7802
7803 return o;
7804}
7805
7806
7807OP *
b162f9ea
IZ		 7808Perl_ck_sassign(pTHX_ OP *o)
7809{
3088bf26 7810 dVAR;
1496a290 7811 OP * const kid = cLISTOPo->op_first;
7918f24d
NC		 7812
7813 PERL_ARGS_ASSERT_CK_SASSIGN;
7814
b162f9ea
IZ		 7815 /* has a disposable target? */
7816 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 7817 && !(kid->op_flags & OPf_STACKED)
7818 /* Cannot steal the second time! */
1b438339
GG		 7819 && !(kid->op_private & OPpTARGET_MY)
7820 /* Keep the full thing for madskills */
7821 && !PL_madskills
7822 )
b162f9ea 7823 {
551405c4 7824 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 7825
7826 /* Can just relocate the target. */
2c2d71f5
JH		 7827 if (kkid && kkid->op_type == OP_PADSV
7828 && !(kkid->op_private & OPpLVAL_INTRO))
7829 {
b162f9ea 7830 kid->op_targ = kkid->op_targ;
743e66e6 7831 kkid->op_targ = 0;
b162f9ea
IZ		 7832 /* Now we do not need PADSV and SASSIGN. */
7833 kid->op_sibling = o->op_sibling; /* NULL */
7834 cLISTOPo->op_first = NULL;
7835 op_free(o);
7836 op_free(kkid);
7837 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7838 return kid;
7839 }
7840 }
c5917253
NC		 7841 if (kid->op_sibling) {
7842 OP *kkid = kid->op_sibling;
7843 if (kkid->op_type == OP_PADSV
7844 && (kkid->op_private & OPpLVAL_INTRO)
7845 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7846 const PADOFFSET target = kkid->op_targ;
7847 OP *const other = newOP(OP_PADSV,
7848 kkid->op_flags
7849 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7850 OP *const first = newOP(OP_NULL, 0);
7851 OP *const nullop = newCONDOP(0, first, o, other);
7852 OP *const condop = first->op_next;
7853 /* hijacking PADSTALE for uninitialized state variables */
7854 SvPADSTALE_on(PAD_SVl(target));
7855
7856 condop->op_type = OP_ONCE;
7857 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7858 condop->op_targ = target;
7859 other->op_targ = target;
7860
95562366
NC		 7861 /* Because we change the type of the op here, we will skip the
7862 assinment binop->op_last = binop->op_first->op_sibling; at the
7863 end of Perl_newBINOP(). So need to do it here. */
7864 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7865
c5917253
NC		 7866 return nullop;
7867 }
7868 }
b162f9ea
IZ		 7869 return o;
7870}
7871
7872OP *
cea2e8a9 7873Perl_ck_match(pTHX_ OP *o)
79072805 7874{
97aff369 7875 dVAR;
7918f24d
NC		 7876
7877 PERL_ARGS_ASSERT_CK_MATCH;
7878
0d863452 7879 if (o->op_type != OP_QR && PL_compcv) {
f8f98e0a 7880 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
00b1698f 7881 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 7882 o->op_targ = offset;
7883 o->op_private |= OPpTARGET_MY;
7884 }
7885 }
7886 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7887 o->op_private |= OPpRUNTIME;
11343788 7888 return o;
79072805
LW		 7889}
7890
7891OP *
f5d5a27c
CS		 7892Perl_ck_method(pTHX_ OP *o)
7893{
551405c4 7894 OP * const kid = cUNOPo->op_first;
7918f24d
NC		 7895
7896 PERL_ARGS_ASSERT_CK_METHOD;
7897
f5d5a27c
CS		 7898 if (kid->op_type == OP_CONST) {
7899 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 7900 const char * const method = SvPVX_const(sv);
7901 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 7902 OP *cmop;
1c846c1f 7903 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
a4fc7abc 7904 sv = newSVpvn_share(method, SvCUR(sv), 0);
1c846c1f
NIS		 7905 }
7906 else {
a0714e2c 7907 kSVOP->op_sv = NULL;
1c846c1f 7908 }
f5d5a27c 7909 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 7910#ifdef PERL_MAD
7911 op_getmad(o,cmop,'O');
7912#else
f5d5a27c 7913 op_free(o);
eb8433b7 7914#endif
f5d5a27c
CS		 7915 return cmop;
7916 }
7917 }
7918 return o;
7919}
7920
7921OP *
cea2e8a9 7922Perl_ck_null(pTHX_ OP *o)
79072805 7923{
7918f24d 7924 PERL_ARGS_ASSERT_CK_NULL;
96a5add6 7925 PERL_UNUSED_CONTEXT;
11343788 7926 return o;
79072805
LW		 7927}
7928
7929OP *
16fe6d59
GS		 7930Perl_ck_open(pTHX_ OP *o)
7931{
97aff369 7932 dVAR;
551405c4 7933 HV * const table = GvHV(PL_hintgv);
7918f24d
NC		 7934
7935 PERL_ARGS_ASSERT_CK_OPEN;
7936
16fe6d59 7937 if (table) {
a4fc7abc 7938 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 7939 if (svp && *svp) {
a79b25b7
VP		 7940 STRLEN len = 0;
7941 const char *d = SvPV_const(*svp, len);
7942 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 7943 if (mode & O_BINARY)
7944 o->op_private |= OPpOPEN_IN_RAW;
7945 else if (mode & O_TEXT)
7946 o->op_private |= OPpOPEN_IN_CRLF;
7947 }
7948
a4fc7abc 7949 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 7950 if (svp && *svp) {
a79b25b7
VP		 7951 STRLEN len = 0;
7952 const char *d = SvPV_const(*svp, len);
7953 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 7954 if (mode & O_BINARY)
7955 o->op_private |= OPpOPEN_OUT_RAW;
7956 else if (mode & O_TEXT)
7957 o->op_private |= OPpOPEN_OUT_CRLF;
7958 }
7959 }
8d7403e6
RGS		 7960 if (o->op_type == OP_BACKTICK) {
7961 if (!(o->op_flags & OPf_KIDS)) {
e4b7ebf3
RGS		 7962 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7963#ifdef PERL_MAD
7964 op_getmad(o,newop,'O');
7965#else
8d7403e6 7966 op_free(o);
e4b7ebf3
RGS		 7967#endif
7968 return newop;
8d7403e6 7969 }
16fe6d59 7970 return o;
8d7403e6 7971 }
3b82e551
JH		 7972 {
7973 /* In case of three-arg dup open remove strictness
7974 * from the last arg if it is a bareword. */
551405c4
AL		 7975 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7976 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 7977 OP *oa;
b15aece3 7978 const char *mode;
3b82e551
JH		 7979
7980 if ((last->op_type == OP_CONST) && /* The bareword. */
7981 (last->op_private & OPpCONST_BARE) &&
7982 (last->op_private & OPpCONST_STRICT) &&
7983 (oa = first->op_sibling) && /* The fh. */
7984 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 7985 (oa->op_type == OP_CONST) &&
3b82e551 7986 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 7987 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 7988 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7989 (last == oa->op_sibling)) /* The bareword. */
7990 last->op_private &= ~OPpCONST_STRICT;
7991 }
16fe6d59
GS		 7992 return ck_fun(o);
7993}
7994
7995OP *
cea2e8a9 7996Perl_ck_repeat(pTHX_ OP *o)
79072805 7997{
7918f24d
NC		 7998 PERL_ARGS_ASSERT_CK_REPEAT;
7999
11343788
MB		 8000 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8001 o->op_private |= OPpREPEAT_DOLIST;
8002 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 8003 }
8004 else
11343788
MB		 8005 scalar(o);
8006 return o;
79072805
LW		 8007}
8008
8009OP *
cea2e8a9 8010Perl_ck_require(pTHX_ OP *o)
8990e307 8011{
97aff369 8012 dVAR;
a0714e2c 8013 GV* gv = NULL;
ec4ab249 8014
7918f24d
NC		 8015 PERL_ARGS_ASSERT_CK_REQUIRE;
8016
11343788 8017 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 8018 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 8019
8020 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 8021 SV * const sv = kid->op_sv;
5c144d81 8022 U32 was_readonly = SvREADONLY(sv);
8990e307 8023 char *s;
cfff9797
NC		 8024 STRLEN len;
8025 const char *end;
5c144d81
NC		 8026
8027 if (was_readonly) {
8028 if (SvFAKE(sv)) {
8029 sv_force_normal_flags(sv, 0);
8030 assert(!SvREADONLY(sv));
8031 was_readonly = 0;
8032 } else {
8033 SvREADONLY_off(sv);
8034 }
8035 }
8036
cfff9797
NC		 8037 s = SvPVX(sv);
8038 len = SvCUR(sv);
8039 end = s + len;
8040 for (; s < end; s++) {
a0d0e21e
LW		 8041 if (*s == ':' && s[1] == ':') {
8042 *s = '/';
5c6b2528 8043 Move(s+2, s+1, end - s - 1, char);
cfff9797 8044 --end;
a0d0e21e 8045 }
8990e307 8046 }
cfff9797 8047 SvEND_set(sv, end);
396482e1 8048 sv_catpvs(sv, ".pm");
5c144d81 8049 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 8050 }
8051 }
ec4ab249 8052
a72a1c8b
RGS		 8053 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8054 /* handle override, if any */
fafc274c 8055 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 8056 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 8057 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 8058 gv = gvp ? *gvp : NULL;
d6a985f2 8059 }
a72a1c8b 8060 }
ec4ab249 8061
b9f751c0 8062 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 8063 OP * const kid = cUNOPo->op_first;
f11453cb
NC		 8064 OP * newop;
8065
ec4ab249 8066 cUNOPo->op_first = 0;
f11453cb 8067#ifndef PERL_MAD
ec4ab249 8068 op_free(o);
eb8433b7 8069#endif
f11453cb
NC		 8070 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8071 append_elem(OP_LIST, kid,
8072 scalar(newUNOP(OP_RV2CV, 0,
8073 newGVOP(OP_GV, 0,
8074 gv))))));
8075 op_getmad(o,newop,'O');
eb8433b7 8076 return newop;
ec4ab249
GA		 8077 }
8078
021f53de 8079 return scalar(ck_fun(o));
8990e307
LW		 8080}
8081
78f9721b
SM		 8082OP *
8083Perl_ck_return(pTHX_ OP *o)
8084{
97aff369 8085 dVAR;
e91684bf 8086 OP *kid;
7918f24d
NC		 8087
8088 PERL_ARGS_ASSERT_CK_RETURN;
8089
e91684bf 8090 kid = cLISTOPo->op_first->op_sibling;
78f9721b 8091 if (CvLVALUE(PL_compcv)) {
e91684bf 8092 for (; kid; kid = kid->op_sibling)
78f9721b 8093 mod(kid, OP_LEAVESUBLV);
e91684bf
VP		 8094 } else {
8095 for (; kid; kid = kid->op_sibling)
8096 if ((kid->op_type == OP_NULL)
1c8a4223 8097 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
e91684bf 8098 /* This is a do block */
1c8a4223
VP		 8099 OP *op = kUNOP->op_first;
8100 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8101 op = cUNOPx(op)->op_first;
8102 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8103 /* Force the use of the caller's context */
8104 op->op_flags |= OPf_SPECIAL;
8105 }
e91684bf 8106 }
78f9721b 8107 }
e91684bf 8108
78f9721b
SM		 8109 return o;
8110}
8111
79072805 8112OP *
cea2e8a9 8113Perl_ck_select(pTHX_ OP *o)
79072805 8114{
27da23d5 8115 dVAR;
c07a80fd 8116 OP* kid;
7918f24d
NC		 8117
8118 PERL_ARGS_ASSERT_CK_SELECT;
8119
11343788
MB		 8120 if (o->op_flags & OPf_KIDS) {
8121 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 8122 if (kid && kid->op_sibling) {
11343788 8123 o->op_type = OP_SSELECT;
22c35a8c 8124 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 8125 o = ck_fun(o);
8126 return fold_constants(o);
79072805
LW		 8127 }
8128 }
11343788
MB		 8129 o = ck_fun(o);
8130 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 8131 if (kid && kid->op_type == OP_RV2GV)
8132 kid->op_private &= ~HINT_STRICT_REFS;
11343788 8133 return o;
79072805
LW		 8134}
8135
8136OP *
cea2e8a9 8137Perl_ck_shift(pTHX_ OP *o)
79072805 8138{
97aff369 8139 dVAR;
6867be6d 8140 const I32 type = o->op_type;
79072805 8141
7918f24d
NC		 8142 PERL_ARGS_ASSERT_CK_SHIFT;
8143
11343788 8144 if (!(o->op_flags & OPf_KIDS)) {
538f5756
RZ		 8145 OP *argop;
8146
8147 if (!CvUNIQUE(PL_compcv)) {
8148 o->op_flags |= OPf_SPECIAL;
8149 return o;
8150 }
8151
8152 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
eb8433b7 8153#ifdef PERL_MAD
790427a5
DM		 8154 {
8155 OP * const oldo = o;
8156 o = newUNOP(type, 0, scalar(argop));
8157 op_getmad(oldo,o,'O');
8158 return o;
8159 }
eb8433b7 8160#else
821005df 8161 op_free(o);
6d4ff0d2 8162 return newUNOP(type, 0, scalar(argop));
eb8433b7 8163#endif
79072805 8164 }
11343788 8165 return scalar(modkids(ck_fun(o), type));
79072805
LW		 8166}
8167
8168OP *
cea2e8a9 8169Perl_ck_sort(pTHX_ OP *o)
79072805 8170{
97aff369 8171 dVAR;
8e3f9bdf 8172 OP *firstkid;
bbce6d69 8173
7918f24d
NC		 8174 PERL_ARGS_ASSERT_CK_SORT;
8175
1496a290 8176 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
a4fc7abc 8177 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 8178 if (hinthv) {
a4fc7abc 8179 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 8180 if (svp) {
a4fc7abc 8181 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 8182 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8183 o->op_private |= OPpSORT_QSORT;
8184 if ((sorthints & HINT_SORT_STABLE) != 0)
8185 o->op_private |= OPpSORT_STABLE;
8186 }
8187 }
8188 }
8189
9ea6e965 8190 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 8191 simplify_sort(o);
8e3f9bdf
GS		 8192 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8193 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 8194 OP *k = NULL;
8e3f9bdf 8195 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 8196
463ee0b2 8197 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 8198 linklist(kid);
463ee0b2
LW		 8199 if (kid->op_type == OP_SCOPE) {
8200 k = kid->op_next;
8201 kid->op_next = 0;
79072805 8202 }
463ee0b2 8203 else if (kid->op_type == OP_LEAVE) {
11343788 8204 if (o->op_type == OP_SORT) {
93c66552 8205 op_null(kid); /* wipe out leave */
748a9306 8206 kid->op_next = kid;
463ee0b2 8207
748a9306
LW		 8208 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8209 if (k->op_next == kid)
8210 k->op_next = 0;
71a29c3c
GS		 8211 /* don't descend into loops */
8212 else if (k->op_type == OP_ENTERLOOP
8213 || k->op_type == OP_ENTERITER)
8214 {
8215 k = cLOOPx(k)->op_lastop;
8216 }
748a9306 8217 }
463ee0b2 8218 }
748a9306
LW		 8219 else
8220 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 8221 k = kLISTOP->op_first;
463ee0b2 8222 }
a2efc822 8223 CALL_PEEP(k);
a0d0e21e 8224
8e3f9bdf
GS		 8225 kid = firstkid;
8226 if (o->op_type == OP_SORT) {
8227 /* provide scalar context for comparison function/block */
8228 kid = scalar(kid);
a0d0e21e 8229 kid->op_next = kid;
8e3f9bdf 8230 }
a0d0e21e
LW		 8231 else
8232 kid->op_next = k;
11343788 8233 o->op_flags |= OPf_SPECIAL;
79072805 8234 }
c6e96bcb 8235 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 8236 op_null(firstkid);
8e3f9bdf
GS		 8237
8238 firstkid = firstkid->op_sibling;
79072805 8239 }
bbce6d69 8240
8e3f9bdf
GS		 8241 /* provide list context for arguments */
8242 if (o->op_type == OP_SORT)
8243 list(firstkid);
8244
11343788 8245 return o;
79072805 8246}
bda4119b
GS		 8247
8248STATIC void
cea2e8a9 8249S_simplify_sort(pTHX_ OP *o)
9c007264 8250{
97aff369 8251 dVAR;
9c007264
JH		 8252 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8253 OP *k;
eb209983 8254 int descending;
350de78d 8255 GV *gv;
770526c1 8256 const char *gvname;
7918f24d
NC		 8257
8258 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8259
9c007264
JH		 8260 if (!(o->op_flags & OPf_STACKED))
8261 return;
fafc274c
NC		 8262 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8263 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 8264 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 8265 if (kid->op_type != OP_SCOPE)
8266 return;
8267 kid = kLISTOP->op_last; /* get past scope */
8268 switch(kid->op_type) {
8269 case OP_NCMP:
8270 case OP_I_NCMP:
8271 case OP_SCMP:
8272 break;
8273 default:
8274 return;
8275 }
8276 k = kid; /* remember this node*/
8277 if (kBINOP->op_first->op_type != OP_RV2SV)
8278 return;
8279 kid = kBINOP->op_first; /* get past cmp */
8280 if (kUNOP->op_first->op_type != OP_GV)
8281 return;
8282 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 8283 gv = kGVOP_gv;
350de78d 8284 if (GvSTASH(gv) != PL_curstash)
9c007264 8285 return;
770526c1
NC		 8286 gvname = GvNAME(gv);
8287 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 8288 descending = 0;
770526c1 8289 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 8290 descending = 1;
9c007264
JH		 8291 else
8292 return;
eb209983 8293
9c007264
JH		 8294 kid = k; /* back to cmp */
8295 if (kBINOP->op_last->op_type != OP_RV2SV)
8296 return;
8297 kid = kBINOP->op_last; /* down to 2nd arg */
8298 if (kUNOP->op_first->op_type != OP_GV)
8299 return;
8300 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 8301 gv = kGVOP_gv;
770526c1
NC		 8302 if (GvSTASH(gv) != PL_curstash)
8303 return;
8304 gvname = GvNAME(gv);
8305 if ( descending
8306 ? !(*gvname == 'a' && gvname[1] == '\0')
8307 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 8308 return;
8309 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 8310 if (descending)
8311 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 8312 if (k->op_type == OP_NCMP)
8313 o->op_private |= OPpSORT_NUMERIC;
8314 if (k->op_type == OP_I_NCMP)
8315 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 8316 kid = cLISTOPo->op_first->op_sibling;
8317 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 8318#ifdef PERL_MAD
8319 op_getmad(kid,o,'S'); /* then delete it */
8320#else
e507f050 8321 op_free(kid); /* then delete it */
eb8433b7 8322#endif
9c007264 8323}
79072805
LW		 8324
8325OP *
cea2e8a9 8326Perl_ck_split(pTHX_ OP *o)
79072805 8327{
27da23d5 8328 dVAR;
79072805 8329 register OP *kid;
aeea060c 8330
7918f24d
NC		 8331 PERL_ARGS_ASSERT_CK_SPLIT;
8332
11343788
MB		 8333 if (o->op_flags & OPf_STACKED)
8334 return no_fh_allowed(o);
79072805 8335
11343788 8336 kid = cLISTOPo->op_first;
8990e307 8337 if (kid->op_type != OP_NULL)
cea2e8a9 8338 Perl_croak(aTHX_ "panic: ck_split");
8990e307 8339 kid = kid->op_sibling;
11343788
MB		 8340 op_free(cLISTOPo->op_first);
8341 cLISTOPo->op_first = kid;
85e6fe83 8342 if (!kid) {
396482e1 8343 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 8344 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 8345 }
79072805 8346
de4bf5b3 8347 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 8348 OP * const sibl = kid->op_sibling;
463ee0b2 8349 kid->op_sibling = 0;
131b3ad0 8350 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 8351 if (cLISTOPo->op_first == cLISTOPo->op_last)
8352 cLISTOPo->op_last = kid;
8353 cLISTOPo->op_first = kid;
79072805
LW		 8354 kid->op_sibling = sibl;
8355 }
8356
8357 kid->op_type = OP_PUSHRE;
22c35a8c 8358 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 8359 scalar(kid);
a2a5de95
NC		 8360 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8361 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8362 "Use of /g modifier is meaningless in split");
f34840d8 8363 }
79072805
LW		 8364
8365 if (!kid->op_sibling)
54b9620d 8366 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 8367
8368 kid = kid->op_sibling;
8369 scalar(kid);
8370
8371 if (!kid->op_sibling)
11343788 8372 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
ce3e5c45 8373 assert(kid->op_sibling);
79072805
LW		 8374
8375 kid = kid->op_sibling;
8376 scalar(kid);
8377
8378 if (kid->op_sibling)
53e06cf0 8379 return too_many_arguments(o,OP_DESC(o));
79072805 8380
11343788 8381 return o;
79072805
LW		 8382}
8383
8384OP *
1c846c1f 8385Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 8386{
551405c4 8387 const OP * const kid = cLISTOPo->op_first->op_sibling;
7918f24d
NC		 8388
8389 PERL_ARGS_ASSERT_CK_JOIN;
8390
041457d9
DM		 8391 if (kid && kid->op_type == OP_MATCH) {
8392 if (ckWARN(WARN_SYNTAX)) {
6867be6d 8393 const REGEXP *re = PM_GETRE(kPMOP);
d2c6dc5e 8394 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
220fc49f 8395 const STRLEN len = re ? RX_PRELEN(re) : 6;
9014280d 8396 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
bcdf7404 8397 "/%.*s/ should probably be written as \"%.*s\"",
d83b45b8 8398 (int)len, pmstr, (int)len, pmstr);
eb6e2d6f
GS		 8399 }
8400 }
8401 return ck_fun(o);
8402}
8403
8404OP *
cea2e8a9 8405Perl_ck_subr(pTHX_ OP *o)
79072805 8406{
97aff369 8407 dVAR;
11343788
MB		 8408 OP *prev = ((cUNOPo->op_first->op_sibling)
8409 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
8410 OP *o2 = prev->op_sibling;
4633a7c4 8411 OP *cvop;
a0751766 8412 const char *proto = NULL;
cbf82dd0 8413 const char *proto_end = NULL;
c445ea15
AL		 8414 CV *cv = NULL;
8415 GV *namegv = NULL;
4633a7c4
LW		 8416 int optional = 0;
8417 I32 arg = 0;
5b794e05 8418 I32 contextclass = 0;
d3fcec1f 8419 const char *e = NULL;
4633a7c4 8420
7918f24d
NC		 8421 PERL_ARGS_ASSERT_CK_SUBR;
8422
d3011074 8423 o->op_private |= OPpENTERSUB_HASTARG;
9d88f058
NC		 8424 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8425 if (PERLDB_SUB && PL_curstash != PL_debstash)
8426 o->op_private |= OPpENTERSUB_DB;
8427
11343788 8428 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4 8429 if (cvop->op_type == OP_RV2CV) {
11343788 8430 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 8431 op_null(cvop); /* disable rv2cv */
f7461760
Z		 8432 if (!(o->op_private & OPpENTERSUB_AMPER)) {
8433 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
8434 GV *gv = NULL;
8435 switch (tmpop->op_type) {
8436 case OP_GV: {
8437 gv = cGVOPx_gv(tmpop);
8438 cv = GvCVu(gv);
8439 if (!cv)
8440 tmpop->op_private |= OPpEARLY_CV;
8441 } break;
8442 case OP_CONST: {
8443 SV *sv = cSVOPx_sv(tmpop);
8444 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8445 cv = (CV*)SvRV(sv);
8446 } break;
8447 }
8448 if (cv && SvPOK(cv)) {
8449 STRLEN len;
8450 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8451 proto = SvPV(MUTABLE_SV(cv), len);
8452 proto_end = proto + len;
46fc3d4c 8453 }
4633a7c4
LW		 8454 }
8455 }
f5d5a27c 8456 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 8457 if (o2->op_type == OP_CONST)
8458 o2->op_private &= ~OPpCONST_STRICT;
58a40671 8459 else if (o2->op_type == OP_LIST) {
5f66b61c
AL		 8460 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8461 if (sib && sib->op_type == OP_CONST)
8462 sib->op_private &= ~OPpCONST_STRICT;
58a40671 8463 }
7a52d87a 8464 }
9d88f058 8465
340458b5
NC		 8466 if (!proto) {
8467 while (o2 != cvop) {
340458b5
NC		 8468 if (PL_madskills && o2->op_type == OP_STUB) {
8469 o2 = o2->op_sibling;
8470 continue;
8471 }
824afba1 8472
340458b5
NC		 8473 /* Yes, this while loop is duplicated. But it's a lot clearer
8474 to see what is going on without that massive switch(*proto)
8475 block just here. */
824afba1 8476
340458b5
NC		 8477 list(o2); /* This is only called if !proto */
8478
8479 mod(o2, OP_ENTERSUB);
9fc012f4 8480 o2 = o2->op_sibling;
340458b5
NC		 8481 } /* while */
8482 } else {
8483 while (o2 != cvop) {
8484 OP* o3;
8485 if (PL_madskills && o2->op_type == OP_STUB) {
8486 o2 = o2->op_sibling;
8487 continue;
8488 }
8489 if (PL_madskills && o2->op_type == OP_NULL)
8490 o3 = ((UNOP*)o2)->op_first;
8491 else
8492 o3 = o2;
8493
cbf82dd0 8494 if (proto >= proto_end)
5dc0d613 8495 return too_many_arguments(o, gv_ename(namegv));
cbf82dd0
NC		 8496
8497 switch (*proto) {
4633a7c4
LW		 8498 case ';':
8499 optional = 1;
8500 proto++;
8501 continue;
b13fd70a 8502 case '_':
f00d1d61 8503 /* _ must be at the end */
cb40c25d 8504 if (proto[1] && proto[1] != ';')
f00d1d61 8505 goto oops;
4633a7c4
LW		 8506 case '$':
8507 proto++;
8508 arg++;
11343788 8509 scalar(o2);
4633a7c4
LW		 8510 break;
8511 case '%':
8512 case '@':
11343788 8513 list(o2);
4633a7c4
LW		 8514 arg++;
8515 break;
8516 case '&':
8517 proto++;
8518 arg++;
eb8433b7 8519 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
75fc29ea 8520 bad_type(arg,
666ea192
JH		 8521 arg == 1 ? "block or sub {}" : "sub {}",
8522 gv_ename(namegv), o3);
4633a7c4
LW		 8523 break;
8524 case '*':
2ba6ecf4 8525 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 8526 proto++;
8527 arg++;
eb8433b7 8528 if (o3->op_type == OP_RV2GV)
2ba6ecf4 8529 goto wrapref; /* autoconvert GLOB -> GLOBref */
eb8433b7
NC		 8530 else if (o3->op_type == OP_CONST)
8531 o3->op_private &= ~OPpCONST_STRICT;
8532 else if (o3->op_type == OP_ENTERSUB) {
9675f7ac 8533 /* accidental subroutine, revert to bareword */
eb8433b7 8534 OP *gvop = ((UNOP*)o3)->op_first;
9675f7ac
GS		 8535 if (gvop && gvop->op_type == OP_NULL) {
8536 gvop = ((UNOP*)gvop)->op_first;
8537 if (gvop) {
8538 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8539 ;
8540 if (gvop &&
8541 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8542 (gvop = ((UNOP*)gvop)->op_first) &&
8543 gvop->op_type == OP_GV)
8544 {
551405c4
AL		 8545 GV * const gv = cGVOPx_gv(gvop);
8546 OP * const sibling = o2->op_sibling;
396482e1 8547 SV * const n = newSVpvs("");
eb8433b7 8548#ifdef PERL_MAD
1d866c12 8549 OP * const oldo2 = o2;
eb8433b7 8550#else
9675f7ac 8551 op_free(o2);
eb8433b7 8552#endif
2a797ae2 8553 gv_fullname4(n, gv, "", FALSE);
2692f720 8554 o2 = newSVOP(OP_CONST, 0, n);
eb8433b7 8555 op_getmad(oldo2,o2,'O');
9675f7ac
GS		 8556 prev->op_sibling = o2;
8557 o2->op_sibling = sibling;
8558 }
8559 }
8560 }
8561 }
2ba6ecf4
GS		 8562 scalar(o2);
8563 break;
5b794e05
JH		 8564 case '[': case ']':
8565 goto oops;
8566 break;
4633a7c4
LW		 8567 case '\\':
8568 proto++;
8569 arg++;
5b794e05 8570 again:
4633a7c4 8571 switch (*proto++) {
5b794e05
JH		 8572 case '[':
8573 if (contextclass++ == 0) {
841d93c8 8574 e = strchr(proto, ']');
5b794e05
JH		 8575 if (!e || e == proto)
8576 goto oops;
8577 }
8578 else
8579 goto oops;
8580 goto again;
8581 break;
8582 case ']':
466bafcd 8583 if (contextclass) {
a0751766
NC		 8584 const char *p = proto;
8585 const char *const end = proto;
466bafcd 8586 contextclass = 0;
47127b64 8587 while (*--p != '[') {}
a0751766
NC		 8588 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8589 (int)(end - p), p),
8590 gv_ename(namegv), o3);
466bafcd 8591 } else
5b794e05
JH		 8592 goto oops;
8593 break;
4633a7c4 8594 case '*':
eb8433b7 8595 if (o3->op_type == OP_RV2GV)
5b794e05
JH		 8596 goto wrapref;
8597 if (!contextclass)
eb8433b7 8598 bad_type(arg, "symbol", gv_ename(namegv), o3);
5b794e05 8599 break;
4633a7c4 8600 case '&':
eb8433b7 8601 if (o3->op_type == OP_ENTERSUB)
5b794e05
JH		 8602 goto wrapref;
8603 if (!contextclass)
eb8433b7
NC		 8604 bad_type(arg, "subroutine entry", gv_ename(namegv),
8605 o3);
5b794e05 8606 break;
4633a7c4 8607 case '$':
eb8433b7
NC		 8608 if (o3->op_type == OP_RV2SV ||
8609 o3->op_type == OP_PADSV ||
8610 o3->op_type == OP_HELEM ||
5b9081af 8611 o3->op_type == OP_AELEM)
5b794e05
JH		 8612 goto wrapref;
8613 if (!contextclass)
eb8433b7 8614 bad_type(arg, "scalar", gv_ename(namegv), o3);
5b794e05 8615 break;
4633a7c4 8616 case '@':
eb8433b7
NC		 8617 if (o3->op_type == OP_RV2AV ||
8618 o3->op_type == OP_PADAV)
5b794e05
JH		 8619 goto wrapref;
8620 if (!contextclass)
eb8433b7 8621 bad_type(arg, "array", gv_ename(namegv), o3);
5b794e05 8622 break;
4633a7c4 8623 case '%':
eb8433b7
NC		 8624 if (o3->op_type == OP_RV2HV ||
8625 o3->op_type == OP_PADHV)
5b794e05
JH		 8626 goto wrapref;
8627 if (!contextclass)
eb8433b7 8628 bad_type(arg, "hash", gv_ename(namegv), o3);
5b794e05
JH		 8629 break;
8630 wrapref:
4633a7c4 8631 {
551405c4
AL		 8632 OP* const kid = o2;
8633 OP* const sib = kid->op_sibling;
4633a7c4 8634 kid->op_sibling = 0;
6fa846a0
GS		 8635 o2 = newUNOP(OP_REFGEN, 0, kid);
8636 o2->op_sibling = sib;
e858de61 8637 prev->op_sibling = o2;
4633a7c4 8638 }
841d93c8 8639 if (contextclass && e) {
5b794e05
JH		 8640 proto = e + 1;
8641 contextclass = 0;
8642 }
4633a7c4
LW		 8643 break;
8644 default: goto oops;
8645 }
5b794e05
JH		 8646 if (contextclass)
8647 goto again;
4633a7c4 8648 break;
b1cb66bf 8649 case ' ':
8650 proto++;
8651 continue;
4633a7c4
LW		 8652 default:
8653 oops:
35c1215d 8654 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
be2597df 8655 gv_ename(namegv), SVfARG(cv));
4633a7c4 8656 }
340458b5
NC		 8657
8658 mod(o2, OP_ENTERSUB);
8659 prev = o2;
8660 o2 = o2->op_sibling;
8661 } /* while */
74735042
NC		 8662
8663 if (o2 == cvop && *proto == '_') {
8664 /* generate an access to $_ */
8665 o2 = newDEFSVOP();
8666 o2->op_sibling = prev->op_sibling;
8667 prev->op_sibling = o2; /* instead of cvop */
8668 }
8669 if (!optional && proto_end > proto &&
8670 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8671 return too_few_arguments(o, gv_ename(namegv));
340458b5 8672 }
11343788 8673 return o;
79072805
LW		 8674}
8675
8676OP *
cea2e8a9 8677Perl_ck_svconst(pTHX_ OP *o)
8990e307 8678{
7918f24d 8679 PERL_ARGS_ASSERT_CK_SVCONST;
96a5add6 8680 PERL_UNUSED_CONTEXT;
11343788
MB		 8681 SvREADONLY_on(cSVOPo->op_sv);
8682 return o;
8990e307
LW		 8683}
8684
8685OP *
d4ac975e
GA		 8686Perl_ck_chdir(pTHX_ OP *o)
8687{
a4e74480 8688 PERL_ARGS_ASSERT_CK_CHDIR;
d4ac975e 8689 if (o->op_flags & OPf_KIDS) {
1496a290 8690 SVOP * const kid = (SVOP*)cUNOPo->op_first;
d4ac975e
GA		 8691
8692 if (kid && kid->op_type == OP_CONST &&
8693 (kid->op_private & OPpCONST_BARE))
8694 {
8695 o->op_flags |= OPf_SPECIAL;
8696 kid->op_private &= ~OPpCONST_STRICT;
8697 }
8698 }
8699 return ck_fun(o);
8700}
8701
8702OP *
cea2e8a9 8703Perl_ck_trunc(pTHX_ OP *o)
79072805 8704{
7918f24d
NC		 8705 PERL_ARGS_ASSERT_CK_TRUNC;
8706
11343788
MB		 8707 if (o->op_flags & OPf_KIDS) {
8708 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 8709
a0d0e21e
LW		 8710 if (kid->op_type == OP_NULL)
8711 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 8712 if (kid && kid->op_type == OP_CONST &&
8713 (kid->op_private & OPpCONST_BARE))
8714 {
11343788 8715 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 8716 kid->op_private &= ~OPpCONST_STRICT;
8717 }
79072805 8718 }
11343788 8719 return ck_fun(o);
79072805
LW		 8720}
8721
35fba0d9 8722OP *
bab9c0ac
RGS		 8723Perl_ck_unpack(pTHX_ OP *o)
8724{
8725 OP *kid = cLISTOPo->op_first;
7918f24d
NC		 8726
8727 PERL_ARGS_ASSERT_CK_UNPACK;
8728
bab9c0ac
RGS		 8729 if (kid->op_sibling) {
8730 kid = kid->op_sibling;
8731 if (!kid->op_sibling)
8732 kid->op_sibling = newDEFSVOP();
8733 }
8734 return ck_fun(o);
8735}
8736
8737OP *
35fba0d9
RG		 8738Perl_ck_substr(pTHX_ OP *o)
8739{
7918f24d
NC		 8740 PERL_ARGS_ASSERT_CK_SUBSTR;
8741
35fba0d9 8742 o = ck_fun(o);
1d866c12 8743 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 8744 OP *kid = cLISTOPo->op_first;
8745
8746 if (kid->op_type == OP_NULL)
8747 kid = kid->op_sibling;
8748 if (kid)
8749 kid->op_flags |= OPf_MOD;
8750
8751 }
8752 return o;
8753}
8754
878d132a
NC		 8755OP *
8756Perl_ck_each(pTHX_ OP *o)
8757{
d75c0fe7 8758 dVAR;
a916b302 8759 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
878d132a 8760
7918f24d
NC		 8761 PERL_ARGS_ASSERT_CK_EACH;
8762
a916b302
RGS		 8763 if (kid) {
8764 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8765 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8766 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8767 o->op_type = new_type;
8768 o->op_ppaddr = PL_ppaddr[new_type];
8769 }
8770 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8771 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8772 )) {
8773 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8774 return o;
8775 }
878d132a
NC		 8776 }
8777 return ck_fun(o);
8778}
8779
867fa1e2
YO		 8780/* caller is supposed to assign the return to the
8781 container of the rep_op var */
20381b50 8782STATIC OP *
867fa1e2 8783S_opt_scalarhv(pTHX_ OP *rep_op) {
749123ff 8784 dVAR;
867fa1e2
YO		 8785 UNOP *unop;
8786
8787 PERL_ARGS_ASSERT_OPT_SCALARHV;
8788
8789 NewOp(1101, unop, 1, UNOP);
8790 unop->op_type = (OPCODE)OP_BOOLKEYS;
8791 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8792 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8793 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8794 unop->op_first = rep_op;
8795 unop->op_next = rep_op->op_next;
8796 rep_op->op_next = (OP*)unop;
8797 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8798 unop->op_sibling = rep_op->op_sibling;
8799 rep_op->op_sibling = NULL;
8800 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8801 if (rep_op->op_type == OP_PADHV) {
8802 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8803 rep_op->op_flags |= OPf_WANT_LIST;
8804 }
8805 return (OP*)unop;
8806}
8807
2f9e2db0
VP		 8808/* Checks if o acts as an in-place operator on an array. oright points to the
8809 * beginning of the right-hand side. Returns the left-hand side of the
8810 * assignment if o acts in-place, or NULL otherwise. */
8811
20381b50 8812STATIC OP *
2f9e2db0
VP		 8813S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8814 OP *o2;
8815 OP *oleft = NULL;
8816
8817 PERL_ARGS_ASSERT_IS_INPLACE_AV;
8818
8819 if (!oright ||
8820 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8821 || oright->op_next != o
8822 || (oright->op_private & OPpLVAL_INTRO)
8823 )
8824 return NULL;
8825
8826 /* o2 follows the chain of op_nexts through the LHS of the
8827 * assign (if any) to the aassign op itself */
8828 o2 = o->op_next;
8829 if (!o2 || o2->op_type != OP_NULL)
8830 return NULL;
8831 o2 = o2->op_next;
8832 if (!o2 || o2->op_type != OP_PUSHMARK)
8833 return NULL;
8834 o2 = o2->op_next;
8835 if (o2 && o2->op_type == OP_GV)
8836 o2 = o2->op_next;
8837 if (!o2
8838 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8839 || (o2->op_private & OPpLVAL_INTRO)
8840 )
8841 return NULL;
8842 oleft = o2;
8843 o2 = o2->op_next;
8844 if (!o2 || o2->op_type != OP_NULL)
8845 return NULL;
8846 o2 = o2->op_next;
8847 if (!o2 || o2->op_type != OP_AASSIGN
8848 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8849 return NULL;
8850
8851 /* check that the sort is the first arg on RHS of assign */
8852
8853 o2 = cUNOPx(o2)->op_first;
8854 if (!o2 || o2->op_type != OP_NULL)
8855 return NULL;
8856 o2 = cUNOPx(o2)->op_first;
8857 if (!o2 || o2->op_type != OP_PUSHMARK)
8858 return NULL;
8859 if (o2->op_sibling != o)
8860 return NULL;
8861
8862 /* check the array is the same on both sides */
8863 if (oleft->op_type == OP_RV2AV) {
8864 if (oright->op_type != OP_RV2AV
8865 || !cUNOPx(oright)->op_first
8866 || cUNOPx(oright)->op_first->op_type != OP_GV
8867 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8868 cGVOPx_gv(cUNOPx(oright)->op_first)
8869 )
8870 return NULL;
8871 }
8872 else if (oright->op_type != OP_PADAV
8873 || oright->op_targ != oleft->op_targ
8874 )
8875 return NULL;
8876
8877 return oleft;
8878}
8879
61b743bb
DM		 8880/* A peephole optimizer. We visit the ops in the order they're to execute.
8881 * See the comments at the top of this file for more details about when
8882 * peep() is called */
463ee0b2 8883
79072805 8884void
1a0a2ba9 8885Perl_rpeep(pTHX_ register OP *o)
79072805 8886{
27da23d5 8887 dVAR;
c445ea15 8888 register OP* oldop = NULL;
2d8e6c8d 8889
2814eb74 8890 if (!o || o->op_opt)
79072805 8891 return;
a0d0e21e 8892 ENTER;
462e5cf6 8893 SAVEOP();
7766f137 8894 SAVEVPTR(PL_curcop);
a0d0e21e 8895 for (; o; o = o->op_next) {
2814eb74 8896 if (o->op_opt)
a0d0e21e 8897 break;
6d7dd4a5
NC		 8898 /* By default, this op has now been optimised. A couple of cases below
8899 clear this again. */
8900 o->op_opt = 1;
533c011a 8901 PL_op = o;
a0d0e21e 8902 switch (o->op_type) {
a0d0e21e 8903 case OP_DBSTATE:
3280af22 8904 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e 8905 break;
ac56e7de
NC		 8906 case OP_NEXTSTATE:
8907 PL_curcop = ((COP*)o); /* for warnings */
8908
8909 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
8910 to carry two labels. For now, take the easier option, and skip
8911 this optimisation if the first NEXTSTATE has a label. */
8912 if (!CopLABEL((COP*)o)) {
8913 OP *nextop = o->op_next;
8914 while (nextop && nextop->op_type == OP_NULL)
8915 nextop = nextop->op_next;
8916
8917 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
8918 COP *firstcop = (COP *)o;
8919 COP *secondcop = (COP *)nextop;
8920 /* We want the COP pointed to by o (and anything else) to
8921 become the next COP down the line. */
8922 cop_free(firstcop);
8923
8924 firstcop->op_next = secondcop->op_next;
8925
8926 /* Now steal all its pointers, and duplicate the other
8927 data. */
8928 firstcop->cop_line = secondcop->cop_line;
8929#ifdef USE_ITHREADS
8930 firstcop->cop_stashpv = secondcop->cop_stashpv;
8931 firstcop->cop_file = secondcop->cop_file;
8932#else
8933 firstcop->cop_stash = secondcop->cop_stash;
8934 firstcop->cop_filegv = secondcop->cop_filegv;
8935#endif
8936 firstcop->cop_hints = secondcop->cop_hints;
8937 firstcop->cop_seq = secondcop->cop_seq;
8938 firstcop->cop_warnings = secondcop->cop_warnings;
8939 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
8940
8941#ifdef USE_ITHREADS
8942 secondcop->cop_stashpv = NULL;
8943 secondcop->cop_file = NULL;
8944#else
8945 secondcop->cop_stash = NULL;
8946 secondcop->cop_filegv = NULL;
8947#endif
8948 secondcop->cop_warnings = NULL;
8949 secondcop->cop_hints_hash = NULL;
8950
8951 /* If we use op_null(), and hence leave an ex-COP, some
8952 warnings are misreported. For example, the compile-time
8953 error in 'use strict; no strict refs;' */
8954 secondcop->op_type = OP_NULL;
8955 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
8956 }
8957 }
8958 break;
a0d0e21e 8959
a0d0e21e 8960 case OP_CONST:
7a52d87a
GS		 8961 if (cSVOPo->op_private & OPpCONST_STRICT)
8962 no_bareword_allowed(o);
7766f137 8963#ifdef USE_ITHREADS
996c9baa 8964 case OP_HINTSEVAL:
3848b962 8965 case OP_METHOD_NAMED:
7766f137
GS		 8966 /* Relocate sv to the pad for thread safety.
8967 * Despite being a "constant", the SV is written to,
8968 * for reference counts, sv_upgrade() etc. */
8969 if (cSVOP->op_sv) {
6867be6d 8970 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
996c9baa 8971 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 8972 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 8973 * some pad, so make a copy. */
dd2155a4
DM		 8974 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8975 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 8976 SvREFCNT_dec(cSVOPo->op_sv);
8977 }
996c9baa 8978 else if (o->op_type != OP_METHOD_NAMED
052ca17e
NC		 8979 && cSVOPo->op_sv == &PL_sv_undef) {
8980 /* PL_sv_undef is hack - it's unsafe to store it in the
8981 AV that is the pad, because av_fetch treats values of
8982 PL_sv_undef as a "free" AV entry and will merrily
8983 replace them with a new SV, causing pad_alloc to think
8984 that this pad slot is free. (When, clearly, it is not)
8985 */
8986 SvOK_off(PAD_SVl(ix));
8987 SvPADTMP_on(PAD_SVl(ix));
8988 SvREADONLY_on(PAD_SVl(ix));
8989 }
6a7129a1 8990 else {
dd2155a4 8991 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 8992 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 8993 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 8994 /* XXX I don't know how this isn't readonly already. */
dd2155a4 8995 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 8996 }
a0714e2c 8997 cSVOPo->op_sv = NULL;
7766f137
GS		 8998 o->op_targ = ix;
8999 }
9000#endif
07447971
GS		 9001 break;
9002
df91b2c5
AE		 9003 case OP_CONCAT:
9004 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9005 if (o->op_next->op_private & OPpTARGET_MY) {
9006 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 9007 break; /* ignore_optimization */
df91b2c5
AE		 9008 else {
9009 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9010 o->op_targ = o->op_next->op_targ;
9011 o->op_next->op_targ = 0;
9012 o->op_private |= OPpTARGET_MY;
9013 }
9014 }
9015 op_null(o->op_next);
9016 }
df91b2c5 9017 break;
6d7dd4a5
NC		 9018 case OP_STUB:
9019 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9020 break; /* Scalar stub must produce undef. List stub is noop */
9021 }
9022 goto nothin;
79072805 9023 case OP_NULL:
acb36ea4 9024 if (o->op_targ == OP_NEXTSTATE
5edb5b2a 9025 || o->op_targ == OP_DBSTATE)
acb36ea4 9026 {
3280af22 9027 PL_curcop = ((COP*)o);
acb36ea4 9028 }
dad75012 9029 /* XXX: We avoid setting op_seq here to prevent later calls
1a0a2ba9 9030 to rpeep() from mistakenly concluding that optimisation
dad75012
AMS		 9031 has already occurred. This doesn't fix the real problem,
9032 though (See 20010220.007). AMS 20010719 */
2814eb74 9033 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 9034 o->op_opt = 0;
f46f2f82 9035 /* FALL THROUGH */
79072805 9036 case OP_SCALAR:
93a17b20 9037 case OP_LINESEQ:
463ee0b2 9038 case OP_SCOPE:
6d7dd4a5 9039 nothin:
a0d0e21e
LW		 9040 if (oldop && o->op_next) {
9041 oldop->op_next = o->op_next;
6d7dd4a5 9042 o->op_opt = 0;
79072805
LW		 9043 continue;
9044 }
79072805
LW		 9045 break;
9046
6a077020 9047 case OP_PADAV:
79072805 9048 case OP_GV:
6a077020 9049 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 9050 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 9051 o->op_next : o->op_next->op_next;
a0d0e21e 9052 IV i;
f9dc862f 9053 if (pop && pop->op_type == OP_CONST &&
af5acbb4 9054 ((PL_op = pop->op_next)) &&
8990e307 9055 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 9056 !(pop->op_next->op_private &
78f9721b 9057 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
fc15ae8f 9058 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
a0d0e21e 9059 <= 255 &&
8990e307
LW		 9060 i >= 0)
9061 {
350de78d 9062 GV *gv;
af5acbb4
DM		 9063 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9064 no_bareword_allowed(pop);
6a077020
DM		 9065 if (o->op_type == OP_GV)
9066 op_null(o->op_next);
93c66552
DM		 9067 op_null(pop->op_next);
9068 op_null(pop);
a0d0e21e
LW		 9069 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9070 o->op_next = pop->op_next->op_next;
22c35a8c 9071 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 9072 o->op_private = (U8)i;
6a077020
DM		 9073 if (o->op_type == OP_GV) {
9074 gv = cGVOPo_gv;
9075 GvAVn(gv);
9076 }
9077 else
9078 o->op_flags |= OPf_SPECIAL;
9079 o->op_type = OP_AELEMFAST;
9080 }
6a077020
DM		 9081 break;
9082 }
9083
9084 if (o->op_next->op_type == OP_RV2SV) {
9085 if (!(o->op_next->op_private & OPpDEREF)) {
9086 op_null(o->op_next);
9087 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9088 | OPpOUR_INTRO);
9089 o->op_next = o->op_next->op_next;
9090 o->op_type = OP_GVSV;
9091 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 9092 }
79072805 9093 }
e476b1b5 9094 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
551405c4 9095 GV * const gv = cGVOPo_gv;
b15aece3 9096 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 9097 /* XXX could check prototype here instead of just carping */
551405c4 9098 SV * const sv = sv_newmortal();
bd61b366 9099 gv_efullname3(sv, gv, NULL);
9014280d 9100 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d 9101 "%"SVf"() called too early to check prototype",
be2597df 9102 SVfARG(sv));
76cd736e
GS		 9103 }
9104 }
89de2904
AMS		 9105 else if (o->op_next->op_type == OP_READLINE
9106 && o->op_next->op_next->op_type == OP_CONCAT
9107 && (o->op_next->op_next->op_flags & OPf_STACKED))
9108 {
d2c45030
AMS		 9109 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9110 o->op_type = OP_RCATLINE;
9111 o->op_flags |= OPf_STACKED;
9112 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 9113 op_null(o->op_next->op_next);
d2c45030 9114 op_null(o->op_next);
89de2904 9115 }
76cd736e 9116
79072805 9117 break;
867fa1e2
YO		 9118
9119 {
9120 OP *fop;
9121 OP *sop;
9122
9123 case OP_NOT:
9124 fop = cUNOP->op_first;
9125 sop = NULL;
9126 goto stitch_keys;
9127 break;
9128
9129 case OP_AND:
79072805 9130 case OP_OR:
c963b151 9131 case OP_DOR:
867fa1e2
YO		 9132 fop = cLOGOP->op_first;
9133 sop = fop->op_sibling;
9134 while (cLOGOP->op_other->op_type == OP_NULL)
9135 cLOGOP->op_other = cLOGOP->op_other->op_next;
1a0a2ba9 9136 CALL_RPEEP(cLOGOP->op_other);
867fa1e2
YO		 9137
9138 stitch_keys:
9139 o->op_opt = 1;
9140 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9141 || ( sop &&
9142 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9143 )
9144 ){
9145 OP * nop = o;
9146 OP * lop = o;
aaf643ce 9147 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
867fa1e2
YO		 9148 while (nop && nop->op_next) {
9149 switch (nop->op_next->op_type) {
9150 case OP_NOT:
9151 case OP_AND:
9152 case OP_OR:
9153 case OP_DOR:
9154 lop = nop = nop->op_next;
9155 break;
9156 case OP_NULL:
9157 nop = nop->op_next;
9158 break;
9159 default:
9160 nop = NULL;
9161 break;
9162 }
9163 }
9164 }
aaf643ce 9165 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
867fa1e2
YO		 9166 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9167 cLOGOP->op_first = opt_scalarhv(fop);
9168 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9169 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9170 }
9171 }
9172
9173
9174 break;
9175 }
9176
9177 case OP_MAPWHILE:
9178 case OP_GREPWHILE:
2c2d71f5
JH		 9179 case OP_ANDASSIGN:
9180 case OP_ORASSIGN:
c963b151 9181 case OP_DORASSIGN:
1a67a97c
SM		 9182 case OP_COND_EXPR:
9183 case OP_RANGE:
c5917253 9184 case OP_ONCE:
fd4d1407
IZ		 9185 while (cLOGOP->op_other->op_type == OP_NULL)
9186 cLOGOP->op_other = cLOGOP->op_other->op_next;
1a0a2ba9 9187 CALL_RPEEP(cLOGOP->op_other);
79072805
LW		 9188 break;
9189
79072805 9190 case OP_ENTERLOOP:
9c2ca71a 9191 case OP_ENTERITER:
58cccf98
SM		 9192 while (cLOOP->op_redoop->op_type == OP_NULL)
9193 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
1a0a2ba9 9194 CALL_RPEEP(cLOOP->op_redoop);
58cccf98
SM		 9195 while (cLOOP->op_nextop->op_type == OP_NULL)
9196 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
1a0a2ba9 9197 CALL_RPEEP(cLOOP->op_nextop);
58cccf98
SM		 9198 while (cLOOP->op_lastop->op_type == OP_NULL)
9199 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
1a0a2ba9 9200 CALL_RPEEP(cLOOP->op_lastop);
79072805
LW		 9201 break;
9202
79072805 9203 case OP_SUBST:
29f2e912
NC		 9204 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9205 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9206 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9207 cPMOP->op_pmstashstartu.op_pmreplstart
9208 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
1a0a2ba9 9209 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 9210 break;
9211
a0d0e21e 9212 case OP_EXEC:
041457d9
DM		 9213 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9214 && ckWARN(WARN_SYNTAX))
9215 {
1496a290
AL		 9216 if (o->op_next->op_sibling) {
9217 const OPCODE type = o->op_next->op_sibling->op_type;
9218 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9219 const line_t oldline = CopLINE(PL_curcop);
9220 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9221 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9222 "Statement unlikely to be reached");
9223 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9224 "\t(Maybe you meant system() when you said exec()?)\n");
9225 CopLINE_set(PL_curcop, oldline);
9226 }
a0d0e21e
LW		 9227 }
9228 }
9229 break;
b2ffa427 9230
c750a3ec 9231 case OP_HELEM: {
e75d1f10 9232 UNOP *rop;
6d822dc4 9233 SV *lexname;
e75d1f10 9234 GV **fields;
6d822dc4 9235 SV **svp, *sv;
d5263905 9236 const char *key = NULL;
c750a3ec 9237 STRLEN keylen;
b2ffa427 9238
1c846c1f 9239 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 9240 break;
1c846c1f
NIS		 9241
9242 /* Make the CONST have a shared SV */
9243 svp = cSVOPx_svp(((BINOP*)o)->op_last);
38bb37b9 9244 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
d5263905 9245 key = SvPV_const(sv, keylen);
25716404 9246 lexname = newSVpvn_share(key,
bb7a0f54 9247 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
25716404 9248 0);
1c846c1f
NIS		 9249 SvREFCNT_dec(sv);
9250 *svp = lexname;
9251 }
e75d1f10
RD		 9252
9253 if ((o->op_private & (OPpLVAL_INTRO)))
9254 break;
9255
9256 rop = (UNOP*)((BINOP*)o)->op_first;
9257 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9258 break;
9259 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
00b1698f 9260 if (!SvPAD_TYPED(lexname))
e75d1f10 9261 break;
a4fc7abc 9262 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 9263 if (!fields || !GvHV(*fields))
9264 break;
93524f2b 9265 key = SvPV_const(*svp, keylen);
e75d1f10 9266 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 9267 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 9268 {
9269 Perl_croak(aTHX_ "No such class field \"%s\" "
9270 "in variable %s of type %s",
93524f2b 9271 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 9272 }
9273
6d822dc4
MS		 9274 break;
9275 }
c750a3ec 9276
e75d1f10
RD		 9277 case OP_HSLICE: {
9278 UNOP *rop;
9279 SV *lexname;
9280 GV **fields;
9281 SV **svp;
93524f2b 9282 const char *key;
e75d1f10
RD		 9283 STRLEN keylen;
9284 SVOP *first_key_op, *key_op;
9285
9286 if ((o->op_private & (OPpLVAL_INTRO))
9287 /* I bet there's always a pushmark... */
9288 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9289 /* hmmm, no optimization if list contains only one key. */
9290 break;
9291 rop = (UNOP*)((LISTOP*)o)->op_last;
9292 if (rop->op_type != OP_RV2HV)
9293 break;
9294 if (rop->op_first->op_type == OP_PADSV)
9295 /* @$hash{qw(keys here)} */
9296 rop = (UNOP*)rop->op_first;
9297 else {
9298 /* @{$hash}{qw(keys here)} */
9299 if (rop->op_first->op_type == OP_SCOPE
9300 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9301 {
9302 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9303 }
9304 else
9305 break;
9306 }
9307
9308 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
00b1698f 9309 if (!SvPAD_TYPED(lexname))
e75d1f10 9310 break;
a4fc7abc 9311 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 9312 if (!fields || !GvHV(*fields))
9313 break;
9314 /* Again guessing that the pushmark can be jumped over.... */
9315 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9316 ->op_first->op_sibling;
9317 for (key_op = first_key_op; key_op;
9318 key_op = (SVOP*)key_op->op_sibling) {
9319 if (key_op->op_type != OP_CONST)
9320 continue;
9321 svp = cSVOPx_svp(key_op);
93524f2b 9322 key = SvPV_const(*svp, keylen);
e75d1f10 9323 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 9324 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 9325 {
9326 Perl_croak(aTHX_ "No such class field \"%s\" "
9327 "in variable %s of type %s",
bfcb3514 9328 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 9329 }
9330 }
9331 break;
9332 }
0824d667
DM		 9333 case OP_RV2SV:
9334 case OP_RV2AV:
9335 case OP_RV2HV:
9336 if (oldop
9337 && ( oldop->op_type == OP_AELEM
9338 || oldop->op_type == OP_PADSV
9339 || oldop->op_type == OP_RV2SV
9340 || oldop->op_type == OP_RV2GV
9341 || oldop->op_type == OP_HELEM
9342 )
9343 && (oldop->op_private & OPpDEREF)
9344 ) {
9345 o->op_private |= OPpDEREFed;
9346 }
e75d1f10 9347
fe1bc4cf 9348 case OP_SORT: {
fe1bc4cf 9349 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
551405c4 9350 OP *oleft;
fe1bc4cf
DM		 9351 OP *o2;
9352
fe1bc4cf 9353 /* check that RHS of sort is a single plain array */
551405c4 9354 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 9355 if (!oright || oright->op_type != OP_PUSHMARK)
9356 break;
471178c0
NC		 9357
9358 /* reverse sort ... can be optimised. */
9359 if (!cUNOPo->op_sibling) {
9360 /* Nothing follows us on the list. */
551405c4 9361 OP * const reverse = o->op_next;
471178c0
NC		 9362
9363 if (reverse->op_type == OP_REVERSE &&
9364 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 9365 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 9366 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9367 && (cUNOPx(pushmark)->op_sibling == o)) {
9368 /* reverse -> pushmark -> sort */
9369 o->op_private |= OPpSORT_REVERSE;
9370 op_null(reverse);
9371 pushmark->op_next = oright->op_next;
9372 op_null(oright);
9373 }
9374 }
9375 }
9376
9377 /* make @a = sort @a act in-place */
9378
fe1bc4cf
DM		 9379 oright = cUNOPx(oright)->op_sibling;
9380 if (!oright)
9381 break;
9382 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9383 oright = cUNOPx(oright)->op_sibling;
9384 }
9385
2f9e2db0
VP		 9386 oleft = is_inplace_av(o, oright);
9387 if (!oleft)
fe1bc4cf
DM		 9388 break;
9389
9390 /* transfer MODishness etc from LHS arg to RHS arg */
9391 oright->op_flags = oleft->op_flags;
9392 o->op_private |= OPpSORT_INPLACE;
9393
9394 /* excise push->gv->rv2av->null->aassign */
9395 o2 = o->op_next->op_next;
9396 op_null(o2); /* PUSHMARK */
9397 o2 = o2->op_next;
9398 if (o2->op_type == OP_GV) {
9399 op_null(o2); /* GV */
9400 o2 = o2->op_next;
9401 }
9402 op_null(o2); /* RV2AV or PADAV */
9403 o2 = o2->op_next->op_next;
9404 op_null(o2); /* AASSIGN */
9405
9406 o->op_next = o2->op_next;
9407
9408 break;
9409 }
ef3e5ea9
NC		 9410
9411 case OP_REVERSE: {
e682d7b7 9412 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 9413 OP *gvop = NULL;
484c818f 9414 OP *oleft, *oright;
ef3e5ea9 9415 LISTOP *enter, *exlist;
ef3e5ea9 9416
484c818f
VP		 9417 /* @a = reverse @a */
9418 if ((oright = cLISTOPo->op_first)
9419 && (oright->op_type == OP_PUSHMARK)
9420 && (oright = oright->op_sibling)
9421 && (oleft = is_inplace_av(o, oright))) {
9422 OP *o2;
9423
9424 /* transfer MODishness etc from LHS arg to RHS arg */
9425 oright->op_flags = oleft->op_flags;
9426 o->op_private |= OPpREVERSE_INPLACE;
9427
9428 /* excise push->gv->rv2av->null->aassign */
9429 o2 = o->op_next->op_next;
9430 op_null(o2); /* PUSHMARK */
9431 o2 = o2->op_next;
9432 if (o2->op_type == OP_GV) {
9433 op_null(o2); /* GV */
9434 o2 = o2->op_next;
9435 }
9436 op_null(o2); /* RV2AV or PADAV */
9437 o2 = o2->op_next->op_next;
9438 op_null(o2); /* AASSIGN */
9439
9440 o->op_next = o2->op_next;
9441 break;
9442 }
9443
ef3e5ea9
NC		 9444 enter = (LISTOP *) o->op_next;
9445 if (!enter)
9446 break;
9447 if (enter->op_type == OP_NULL) {
9448 enter = (LISTOP *) enter->op_next;
9449 if (!enter)
9450 break;
9451 }
d46f46af
NC		 9452 /* for $a (...) will have OP_GV then OP_RV2GV here.
9453 for (...) just has an OP_GV. */
ce335f37
NC		 9454 if (enter->op_type == OP_GV) {
9455 gvop = (OP *) enter;
9456 enter = (LISTOP *) enter->op_next;
9457 if (!enter)
9458 break;
d46f46af
NC		 9459 if (enter->op_type == OP_RV2GV) {
9460 enter = (LISTOP *) enter->op_next;
9461 if (!enter)
ce335f37 9462 break;
d46f46af 9463 }
ce335f37
NC		 9464 }
9465
ef3e5ea9
NC		 9466 if (enter->op_type != OP_ENTERITER)
9467 break;
9468
9469 iter = enter->op_next;
9470 if (!iter || iter->op_type != OP_ITER)
9471 break;
9472
ce335f37
NC		 9473 expushmark = enter->op_first;
9474 if (!expushmark || expushmark->op_type != OP_NULL
9475 || expushmark->op_targ != OP_PUSHMARK)
9476 break;
9477
9478 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 9479 if (!exlist || exlist->op_type != OP_NULL
9480 || exlist->op_targ != OP_LIST)
9481 break;
9482
9483 if (exlist->op_last != o) {
9484 /* Mmm. Was expecting to point back to this op. */
9485 break;
9486 }
9487 theirmark = exlist->op_first;
9488 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9489 break;
9490
c491ecac 9491 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 9492 /* There's something between the mark and the reverse, eg
9493 for (1, reverse (...))
9494 so no go. */
9495 break;
9496 }
9497
c491ecac
NC		 9498 ourmark = ((LISTOP *)o)->op_first;
9499 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9500 break;
9501
ef3e5ea9
NC		 9502 ourlast = ((LISTOP *)o)->op_last;
9503 if (!ourlast || ourlast->op_next != o)
9504 break;
9505
e682d7b7
NC		 9506 rv2av = ourmark->op_sibling;
9507 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9508 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9509 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9510 /* We're just reversing a single array. */
9511 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9512 enter->op_flags |= OPf_STACKED;
9513 }
9514
ef3e5ea9
NC		 9515 /* We don't have control over who points to theirmark, so sacrifice
9516 ours. */
9517 theirmark->op_next = ourmark->op_next;
9518 theirmark->op_flags = ourmark->op_flags;
ce335f37 9519 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 9520 op_null(ourmark);
9521 op_null(o);
9522 enter->op_private |= OPpITER_REVERSED;
9523 iter->op_private |= OPpITER_REVERSED;
9524
9525 break;
9526 }
e26df76a
NC		 9527
9528 case OP_SASSIGN: {
9529 OP *rv2gv;
9530 UNOP *refgen, *rv2cv;
9531 LISTOP *exlist;
9532
50baa5ea 9533 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
de3370bc
NC		 9534 break;
9535
e26df76a
NC		 9536 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9537 break;
9538
9539 rv2gv = ((BINOP *)o)->op_last;
9540 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9541 break;
9542
9543 refgen = (UNOP *)((BINOP *)o)->op_first;
9544
9545 if (!refgen || refgen->op_type != OP_REFGEN)
9546 break;
9547
9548 exlist = (LISTOP *)refgen->op_first;
9549 if (!exlist || exlist->op_type != OP_NULL
9550 || exlist->op_targ != OP_LIST)
9551 break;
9552
9553 if (exlist->op_first->op_type != OP_PUSHMARK)
9554 break;
9555
9556 rv2cv = (UNOP*)exlist->op_last;
9557
9558 if (rv2cv->op_type != OP_RV2CV)
9559 break;
9560
9561 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9562 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9563 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9564
9565 o->op_private |= OPpASSIGN_CV_TO_GV;
9566 rv2gv->op_private |= OPpDONT_INIT_GV;
9567 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9568
9569 break;
9570 }
9571
fe1bc4cf 9572
0477511c
NC		 9573 case OP_QR:
9574 case OP_MATCH:
29f2e912
NC		 9575 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9576 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9577 }
79072805
LW		 9578 break;
9579 }
a0d0e21e 9580 oldop = o;
79072805 9581 }
a0d0e21e 9582 LEAVE;
79072805 9583}
beab0874 9584
1a0a2ba9
Z		 9585void
9586Perl_peep(pTHX_ register OP *o)
9587{
9588 CALL_RPEEP(o);
9589}
9590
cef6ea9d 9591const char*
1cb0ed9b 9592Perl_custom_op_name(pTHX_ const OP* o)
53e06cf0 9593{
97aff369 9594 dVAR;
e1ec3a88 9595 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 9596 SV* keysv;
9597 HE* he;
9598
7918f24d
NC		 9599 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9600
53e06cf0 9601 if (!PL_custom_op_names) /* This probably shouldn't happen */
27da23d5 9602 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 9603
9604 keysv = sv_2mortal(newSViv(index));
9605
9606 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9607 if (!he)
27da23d5 9608 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 9609
9610 return SvPV_nolen(HeVAL(he));
9611}
9612
cef6ea9d 9613const char*
1cb0ed9b 9614Perl_custom_op_desc(pTHX_ const OP* o)
53e06cf0 9615{
97aff369 9616 dVAR;
e1ec3a88 9617 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 9618 SV* keysv;
9619 HE* he;
9620
7918f24d
NC		 9621 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9622
53e06cf0 9623 if (!PL_custom_op_descs)
27da23d5 9624 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 9625
9626 keysv = sv_2mortal(newSViv(index));
9627
9628 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9629 if (!he)
27da23d5 9630 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 9631
9632 return SvPV_nolen(HeVAL(he));
9633}
19e8ce8e 9634
beab0874
JT		 9635#include "XSUB.h"
9636
9637/* Efficient sub that returns a constant scalar value. */
9638static void
acfe0abc 9639const_sv_xsub(pTHX_ CV* cv)
beab0874 9640{
97aff369 9641 dVAR;
beab0874 9642 dXSARGS;
99ab892b 9643 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9cbac4c7 9644 if (items != 0) {
6f207bd3 9645 NOOP;
9cbac4c7 9646#if 0
fe13d51d 9647 /* diag_listed_as: SKIPME */
9cbac4c7 9648 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 9649 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 9650#endif
9651 }
99ab892b
NC		 9652 if (!sv) {
9653 XSRETURN(0);
9654 }
9a049f1c 9655 EXTEND(sp, 1);
99ab892b 9656 ST(0) = sv;
beab0874
JT		 9657 XSRETURN(1);
9658}
4946a0fa
NC		 9659
9660/*
9661 * Local variables:
9662 * c-indentation-style: bsd
9663 * c-basic-offset: 4
9664 * indent-tabs-mode: t
9665 * End:
9666 *
37442d52
RGS		 9667 * ex: set ts=8 sts=4 sw=4 noet:
9668 */
Unnamed repository; edit this file 'description' to name the repository.