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