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