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
arybase.xs: Remove extraneous semicolon
[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
GG		 3600
3601 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3602 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3603 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3604 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3605
b7dc083c 3606 NewOp(1101, o, 1, OP);
eb160463 3607 o->op_type = (OPCODE)type;
22c35a8c 3608 o->op_ppaddr = PL_ppaddr[type];
eb160463 3609 o->op_flags = (U8)flags;
670f3923
DM		 3610 o->op_latefree = 0;
3611 o->op_latefreed = 0;
7e5d8ed2 3612 o->op_attached = 0;
79072805 3613
11343788 3614 o->op_next = o;
eb160463 3615 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 3616 if (PL_opargs[type] & OA_RETSCALAR)
11343788 3617 scalar(o);
22c35a8c 3618 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 3619 o->op_targ = pad_alloc(type, SVs_PADTMP);
3620 return CHECKOP(type, o);
79072805
LW		 3621}
3622
d67eb5f4
Z		 3623/*
3624=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3625
3626Constructs, checks, and returns an op of any unary type. I<type> is
3627the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3628C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3629bits, the eight bits of C<op_private>, except that the bit with value 1
3630is automatically set. I<first> supplies an optional op to be the direct
3631child of the unary op; it is consumed by this function and become part
3632of the constructed op tree.
3633
3634=cut
3635*/
3636
79072805 3637OP *
864dbfa3 3638Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 3639{
27da23d5 3640 dVAR;
79072805
LW		 3641 UNOP *unop;
3642
e69777c1
GG		 3643 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3644 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3645 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3646 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3647 || type == OP_SASSIGN
32e2a35d 3648 || type == OP_ENTERTRY
e69777c1
GG		 3649 || type == OP_NULL );
3650
93a17b20 3651 if (!first)
aeea060c 3652 first = newOP(OP_STUB, 0);
22c35a8c 3653 if (PL_opargs[type] & OA_MARK)
8990e307 3654 first = force_list(first);
93a17b20 3655
b7dc083c 3656 NewOp(1101, unop, 1, UNOP);
eb160463 3657 unop->op_type = (OPCODE)type;
22c35a8c 3658 unop->op_ppaddr = PL_ppaddr[type];
79072805 3659 unop->op_first = first;
585ec06d 3660 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 3661 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 3662 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 3663 if (unop->op_next)
3664 return (OP*)unop;
3665
985b9e54 3666 return fold_constants(op_integerize(op_std_init((OP *) unop)));
79072805
LW		 3667}
3668
d67eb5f4
Z		 3669/*
3670=for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3671
3672Constructs, checks, and returns an op of any binary type. I<type>
3673is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3674that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3675the eight bits of C<op_private>, except that the bit with value 1 or
36762 is automatically set as required. I<first> and I<last> supply up to
3677two ops to be the direct children of the binary op; they are consumed
3678by this function and become part of the constructed op tree.
3679
3680=cut
3681*/
3682
79072805 3683OP *
864dbfa3 3684Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3685{
27da23d5 3686 dVAR;
79072805 3687 BINOP *binop;
e69777c1
GG		 3688
3689 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3690 || type == OP_SASSIGN || type == OP_NULL );
3691
b7dc083c 3692 NewOp(1101, binop, 1, BINOP);
79072805
LW		 3693
3694 if (!first)
3695 first = newOP(OP_NULL, 0);
3696
eb160463 3697 binop->op_type = (OPCODE)type;
22c35a8c 3698 binop->op_ppaddr = PL_ppaddr[type];
79072805 3699 binop->op_first = first;
585ec06d 3700 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 3701 if (!last) {
3702 last = first;
eb160463 3703 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3704 }
3705 else {
eb160463 3706 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 3707 first->op_sibling = last;
3708 }
3709
e50aee73 3710 binop = (BINOP*)CHECKOP(type, binop);
eb160463 3711 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 3712 return (OP*)binop;
3713
7284ab6f 3714 binop->op_last = binop->op_first->op_sibling;
79072805 3715
985b9e54 3716 return fold_constants(op_integerize(op_std_init((OP *)binop)));
79072805
LW		 3717}
3718
5f66b61c
AL		 3719static int uvcompare(const void *a, const void *b)
3720 __attribute__nonnull__(1)
3721 __attribute__nonnull__(2)
3722 __attribute__pure__;
abb2c242 3723static int uvcompare(const void *a, const void *b)
2b9d42f0 3724{
e1ec3a88 3725 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 3726 return -1;
e1ec3a88 3727 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 3728 return 1;
e1ec3a88 3729 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 3730 return -1;
e1ec3a88 3731 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 3732 return 1;
a0ed51b3
LW		 3733 return 0;
3734}
3735
0d86688d
NC		 3736static OP *
3737S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 3738{
97aff369 3739 dVAR;
2d03de9c 3740 SV * const tstr = ((SVOP*)expr)->op_sv;
fbbb0949
DM		 3741 SV * const rstr =
3742#ifdef PERL_MAD
3743 (repl->op_type == OP_NULL)
3744 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3745#endif
3746 ((SVOP*)repl)->op_sv;
463ee0b2
LW		 3747 STRLEN tlen;
3748 STRLEN rlen;
5c144d81
NC		 3749 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3750 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 3751 register I32 i;
3752 register I32 j;
9b877dbb 3753 I32 grows = 0;
79072805
LW		 3754 register short *tbl;
3755
551405c4
AL		 3756 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3757 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3758 I32 del = o->op_private & OPpTRANS_DELETE;
043e41b8 3759 SV* swash;
7918f24d
NC		 3760
3761 PERL_ARGS_ASSERT_PMTRANS;
3762
800b4dc4 3763 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 3764
036b4402
GS		 3765 if (SvUTF8(tstr))
3766 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 3767
3768 if (SvUTF8(rstr))
036b4402 3769 o->op_private |= OPpTRANS_TO_UTF;
79072805 3770
a0ed51b3 3771 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 3772 SV* const listsv = newSVpvs("# comment\n");
c445ea15 3773 SV* transv = NULL;
5c144d81
NC		 3774 const U8* tend = t + tlen;
3775 const U8* rend = r + rlen;
ba210ebe 3776 STRLEN ulen;
84c133a0
RB		 3777 UV tfirst = 1;
3778 UV tlast = 0;
3779 IV tdiff;
3780 UV rfirst = 1;
3781 UV rlast = 0;
3782 IV rdiff;
3783 IV diff;
a0ed51b3
LW		 3784 I32 none = 0;
3785 U32 max = 0;
3786 I32 bits;
a0ed51b3 3787 I32 havefinal = 0;
9c5ffd7c 3788 U32 final = 0;
551405c4
AL		 3789 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3790 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 3791 U8* tsave = NULL;
3792 U8* rsave = NULL;
9f7f3913 3793 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 3794
3795 if (!from_utf) {
3796 STRLEN len = tlen;
5c144d81 3797 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 3798 tend = t + len;
3799 }
3800 if (!to_utf && rlen) {
3801 STRLEN len = rlen;
5c144d81 3802 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 3803 rend = r + len;
3804 }
a0ed51b3 3805
2b9d42f0
NIS		 3806/* There are several snags with this code on EBCDIC:
3807 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3808 2. scan_const() in toke.c has encoded chars in native encoding which makes
3809 ranges at least in EBCDIC 0..255 range the bottom odd.
3810*/
3811
a0ed51b3 3812 if (complement) {
89ebb4a3 3813 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 3814 UV *cp;
a0ed51b3 3815 UV nextmin = 0;
a02a5408 3816 Newx(cp, 2*tlen, UV);
a0ed51b3 3817 i = 0;
396482e1 3818 transv = newSVpvs("");
a0ed51b3 3819 while (t < tend) {
9f7f3913 3820 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS		 3821 t += ulen;
3822 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 3823 t++;
9f7f3913 3824 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 3825 t += ulen;
a0ed51b3 3826 }
2b9d42f0
NIS		 3827 else {
3828 cp[2*i+1] = cp[2*i];
3829 }
3830 i++;
a0ed51b3 3831 }
2b9d42f0 3832 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 3833 for (j = 0; j < i; j++) {
2b9d42f0 3834 UV val = cp[2*j];
a0ed51b3
LW		 3835 diff = val - nextmin;
3836 if (diff > 0) {
9041c2e3 3837 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3838 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 3839 if (diff > 1) {
2b9d42f0 3840 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 3841 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 3842 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 3843 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 3844 }
3845 }
2b9d42f0 3846 val = cp[2*j+1];
a0ed51b3
LW		 3847 if (val >= nextmin)
3848 nextmin = val + 1;
3849 }
9041c2e3 3850 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3851 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 3852 {
3853 U8 range_mark = UTF_TO_NATIVE(0xff);
3854 sv_catpvn(transv, (char *)&range_mark, 1);
3855 }
6247ead0 3856 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
dfe13c55 3857 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 3858 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 3859 tlen = SvCUR(transv);
3860 tend = t + tlen;
455d824a 3861 Safefree(cp);
a0ed51b3
LW		 3862 }
3863 else if (!rlen && !del) {
3864 r = t; rlen = tlen; rend = tend;
4757a243
LW		 3865 }
3866 if (!squash) {
05d340b8 3867 if ((!rlen && !del) || t == r ||
12ae5dfc 3868 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 3869 {
4757a243 3870 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 3871 }
a0ed51b3
LW		 3872 }
3873
3874 while (t < tend || tfirst <= tlast) {
3875 /* see if we need more "t" chars */
3876 if (tfirst > tlast) {
9f7f3913 3877 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 3878 t += ulen;
2b9d42f0 3879 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3880 t++;
9f7f3913 3881 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW		 3882 t += ulen;
3883 }
3884 else
3885 tlast = tfirst;
3886 }
3887
3888 /* now see if we need more "r" chars */
3889 if (rfirst > rlast) {
3890 if (r < rend) {
9f7f3913 3891 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 3892 r += ulen;
2b9d42f0 3893 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3894 r++;
9f7f3913 3895 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW		 3896 r += ulen;
3897 }
3898 else
3899 rlast = rfirst;
3900 }
3901 else {
3902 if (!havefinal++)
3903 final = rlast;
3904 rfirst = rlast = 0xffffffff;
3905 }
3906 }
3907
3908 /* now see which range will peter our first, if either. */
3909 tdiff = tlast - tfirst;
3910 rdiff = rlast - rfirst;
3911
3912 if (tdiff <= rdiff)
3913 diff = tdiff;
3914 else
3915 diff = rdiff;
3916
3917 if (rfirst == 0xffffffff) {
3918 diff = tdiff; /* oops, pretend rdiff is infinite */
3919 if (diff > 0)
894356b3
GS		 3920 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3921 (long)tfirst, (long)tlast);
a0ed51b3 3922 else
894356b3 3923 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 3924 }
3925 else {
3926 if (diff > 0)
894356b3
GS		 3927 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3928 (long)tfirst, (long)(tfirst + diff),
3929 (long)rfirst);
a0ed51b3 3930 else
894356b3
GS		 3931 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3932 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 3933
3934 if (rfirst + diff > max)
3935 max = rfirst + diff;
9b877dbb 3936 if (!grows)
45005bfb
JH		 3937 grows = (tfirst < rfirst &&
3938 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3939 rfirst += diff + 1;
a0ed51b3
LW		 3940 }
3941 tfirst += diff + 1;
3942 }
3943
3944 none = ++max;
3945 if (del)
3946 del = ++max;
3947
3948 if (max > 0xffff)
3949 bits = 32;
3950 else if (max > 0xff)
3951 bits = 16;
3952 else
3953 bits = 8;
3954
ea71c68d 3955 PerlMemShared_free(cPVOPo->op_pv);
b3123a61 3956 cPVOPo->op_pv = NULL;
043e41b8 3957
ad64d0ec 3958 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
043e41b8
DM		 3959#ifdef USE_ITHREADS
3960 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3961 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3962 PAD_SETSV(cPADOPo->op_padix, swash);
3963 SvPADTMP_on(swash);
a5446a64 3964 SvREADONLY_on(swash);
043e41b8
DM		 3965#else
3966 cSVOPo->op_sv = swash;
3967#endif
a0ed51b3 3968 SvREFCNT_dec(listsv);
b37c2d43 3969 SvREFCNT_dec(transv);
a0ed51b3 3970
45005bfb 3971 if (!del && havefinal && rlen)
85fbaab2 3972 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
b448e4fe 3973 newSVuv((UV)final), 0);
a0ed51b3 3974
9b877dbb 3975 if (grows)
a0ed51b3
LW		 3976 o->op_private |= OPpTRANS_GROWS;
3977
b37c2d43
AL		 3978 Safefree(tsave);
3979 Safefree(rsave);
9b877dbb 3980
eb8433b7
NC		 3981#ifdef PERL_MAD
3982 op_getmad(expr,o,'e');
3983 op_getmad(repl,o,'r');
3984#else
a0ed51b3
LW		 3985 op_free(expr);
3986 op_free(repl);
eb8433b7 3987#endif
a0ed51b3
LW		 3988 return o;
3989 }
3990
3991 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 3992 if (complement) {
3993 Zero(tbl, 256, short);
eb160463 3994 for (i = 0; i < (I32)tlen; i++)
ec49126f 3995 tbl[t[i]] = -1;
79072805
LW		 3996 for (i = 0, j = 0; i < 256; i++) {
3997 if (!tbl[i]) {
eb160463 3998 if (j >= (I32)rlen) {
a0ed51b3 3999 if (del)
79072805
LW		 4000 tbl[i] = -2;
4001 else if (rlen)
ec49126f 4002 tbl[i] = r[j-1];
79072805 4003 else
eb160463 4004 tbl[i] = (short)i;
79072805 4005 }
9b877dbb
IH		 4006 else {
4007 if (i < 128 && r[j] >= 128)
4008 grows = 1;
ec49126f 4009 tbl[i] = r[j++];
9b877dbb 4010 }
79072805
LW		 4011 }
4012 }
05d340b8
JH		 4013 if (!del) {
4014 if (!rlen) {
4015 j = rlen;
4016 if (!squash)
4017 o->op_private |= OPpTRANS_IDENTICAL;
4018 }
eb160463 4019 else if (j >= (I32)rlen)
05d340b8 4020 j = rlen - 1;
10db182f 4021 else {
aa1f7c5b
JH		 4022 tbl =
4023 (short *)
4024 PerlMemShared_realloc(tbl,
4025 (0x101+rlen-j) * sizeof(short));
10db182f
YO		 4026 cPVOPo->op_pv = (char*)tbl;
4027 }
585ec06d 4028 tbl[0x100] = (short)(rlen - j);
eb160463 4029 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 4030 tbl[0x101+i] = r[j+i];
4031 }
79072805
LW		 4032 }
4033 else {
a0ed51b3 4034 if (!rlen && !del) {
79072805 4035 r = t; rlen = tlen;
5d06d08e 4036 if (!squash)
4757a243 4037 o->op_private |= OPpTRANS_IDENTICAL;
79072805 4038 }
94bfe852
RGS		 4039 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4040 o->op_private |= OPpTRANS_IDENTICAL;
4041 }
79072805
LW		 4042 for (i = 0; i < 256; i++)
4043 tbl[i] = -1;
eb160463
GS		 4044 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4045 if (j >= (I32)rlen) {
a0ed51b3 4046 if (del) {
ec49126f 4047 if (tbl[t[i]] == -1)
4048 tbl[t[i]] = -2;
79072805
LW		 4049 continue;
4050 }
4051 --j;
4052 }
9b877dbb
IH		 4053 if (tbl[t[i]] == -1) {
4054 if (t[i] < 128 && r[j] >= 128)
4055 grows = 1;
ec49126f 4056 tbl[t[i]] = r[j];
9b877dbb 4057 }
79072805
LW		 4058 }
4059 }
b08e453b 4060
a2a5de95
NC		 4061 if(del && rlen == tlen) {
4062 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4063 } else if(rlen > tlen) {
4064 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
b08e453b
RB		 4065 }
4066
9b877dbb
IH		 4067 if (grows)
4068 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 4069#ifdef PERL_MAD
4070 op_getmad(expr,o,'e');
4071 op_getmad(repl,o,'r');
4072#else
79072805
LW		 4073 op_free(expr);
4074 op_free(repl);
eb8433b7 4075#endif
79072805 4076
11343788 4077 return o;
79072805
LW		 4078}
4079
d67eb5f4
Z		 4080/*
4081=for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4082
4083Constructs, checks, and returns an op of any pattern matching type.
4084I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4085and, shifted up eight bits, the eight bits of C<op_private>.
4086
4087=cut
4088*/
4089
79072805 4090OP *
864dbfa3 4091Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 4092{
27da23d5 4093 dVAR;
79072805
LW		 4094 PMOP *pmop;
4095
e69777c1
GG		 4096 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4097
b7dc083c 4098 NewOp(1101, pmop, 1, PMOP);
eb160463 4099 pmop->op_type = (OPCODE)type;
22c35a8c 4100 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 4101 pmop->op_flags = (U8)flags;
4102 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 4103
3280af22 4104 if (PL_hints & HINT_RE_TAINT)
c737faaf 4105 pmop->op_pmflags |= PMf_RETAINT;
9de15fec 4106 if (PL_hints & HINT_LOCALE) {
a62b1201 4107 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
9de15fec
KW		 4108 }
4109 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
a62b1201 4110 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
9de15fec 4111 }
1e215989 4112 if (PL_hints & HINT_RE_FLAGS) {
20439bc7
Z		 4113 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4114 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
1e215989
FC		 4115 );
4116 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
20439bc7 4117 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6320bfaf 4118 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
1e215989
FC		 4119 );
4120 if (reflags && SvOK(reflags)) {
dabded94 4121 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
1e215989
FC		 4122 }
4123 }
c737faaf 4124
36477c24 4125
debc9467 4126#ifdef USE_ITHREADS
402d2eb1
NC		 4127 assert(SvPOK(PL_regex_pad[0]));
4128 if (SvCUR(PL_regex_pad[0])) {
4129 /* Pop off the "packed" IV from the end. */
4130 SV *const repointer_list = PL_regex_pad[0];
4131 const char *p = SvEND(repointer_list) - sizeof(IV);
4132 const IV offset = *((IV*)p);
4133
4134 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4135
4136 SvEND_set(repointer_list, p);
4137
110f3028 4138 pmop->op_pmoffset = offset;
14a49a24
NC		 4139 /* This slot should be free, so assert this: */
4140 assert(PL_regex_pad[offset] == &PL_sv_undef);
551405c4 4141 } else {
14a49a24 4142 SV * const repointer = &PL_sv_undef;
9a8b6709 4143 av_push(PL_regex_padav, repointer);
551405c4
AL		 4144 pmop->op_pmoffset = av_len(PL_regex_padav);
4145 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 4146 }
debc9467 4147#endif
1eb1540c 4148
463d09e6 4149 return CHECKOP(type, pmop);
79072805
LW		 4150}
4151
131b3ad0
DM		 4152/* Given some sort of match op o, and an expression expr containing a
4153 * pattern, either compile expr into a regex and attach it to o (if it's
4154 * constant), or convert expr into a runtime regcomp op sequence (if it's
4155 * not)
4156 *
4157 * isreg indicates that the pattern is part of a regex construct, eg
4158 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4159 * split "pattern", which aren't. In the former case, expr will be a list
4160 * if the pattern contains more than one term (eg /a$b/) or if it contains
4161 * a replacement, ie s/// or tr///.
4162 */
4163
79072805 4164OP *
131b3ad0 4165Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 4166{
27da23d5 4167 dVAR;
79072805
LW		 4168 PMOP *pm;
4169 LOGOP *rcop;
ce862d02 4170 I32 repl_has_vars = 0;
5f66b61c 4171 OP* repl = NULL;
131b3ad0
DM		 4172 bool reglist;
4173
7918f24d
NC		 4174 PERL_ARGS_ASSERT_PMRUNTIME;
4175
bb16bae8
FC		 4176 if (
4177 o->op_type == OP_SUBST
4178 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4179 ) {
131b3ad0
DM		 4180 /* last element in list is the replacement; pop it */
4181 OP* kid;
4182 repl = cLISTOPx(expr)->op_last;
4183 kid = cLISTOPx(expr)->op_first;
4184 while (kid->op_sibling != repl)
4185 kid = kid->op_sibling;
5f66b61c 4186 kid->op_sibling = NULL;
131b3ad0
DM		 4187 cLISTOPx(expr)->op_last = kid;
4188 }
79072805 4189
131b3ad0
DM		 4190 if (isreg && expr->op_type == OP_LIST &&
4191 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4192 {
4193 /* convert single element list to element */
0bd48802 4194 OP* const oe = expr;
131b3ad0 4195 expr = cLISTOPx(oe)->op_first->op_sibling;
5f66b61c
AL		 4196 cLISTOPx(oe)->op_first->op_sibling = NULL;
4197 cLISTOPx(oe)->op_last = NULL;
131b3ad0
DM		 4198 op_free(oe);
4199 }
4200
bb16bae8 4201 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
11343788 4202 return pmtrans(o, expr, repl);
131b3ad0
DM		 4203 }
4204
4205 reglist = isreg && expr->op_type == OP_LIST;
4206 if (reglist)
4207 op_null(expr);
79072805 4208
3280af22 4209 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4210 pm = (PMOP*)o;
79072805
LW		 4211
4212 if (expr->op_type == OP_CONST) {
b9ad30b4 4213 SV *pat = ((SVOP*)expr)->op_sv;
73134a2e 4214 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5c144d81 4215
0ac6acae
AB		 4216 if (o->op_flags & OPf_SPECIAL)
4217 pm_flags |= RXf_SPLIT;
5c144d81 4218
b9ad30b4
NC		 4219 if (DO_UTF8(pat)) {
4220 assert (SvUTF8(pat));
4221 } else if (SvUTF8(pat)) {
4222 /* Not doing UTF-8, despite what the SV says. Is this only if we're
4223 trapped in use 'bytes'? */
4224 /* Make a copy of the octet sequence, but without the flag on, as
4225 the compiler now honours the SvUTF8 flag on pat. */
4226 STRLEN len;
4227 const char *const p = SvPV(pat, len);
4228 pat = newSVpvn_flags(p, len, SVs_TEMP);
4229 }
0ac6acae 4230
3ab4a224 4231 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
c737faaf 4232
eb8433b7
NC		 4233#ifdef PERL_MAD
4234 op_getmad(expr,(OP*)pm,'e');
4235#else
79072805 4236 op_free(expr);
eb8433b7 4237#endif
79072805
LW		 4238 }
4239 else {
3280af22 4240 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 4241 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 4242 ? OP_REGCRESET
4243 : OP_REGCMAYBE),0,expr);
463ee0b2 4244
b7dc083c 4245 NewOp(1101, rcop, 1, LOGOP);
79072805 4246 rcop->op_type = OP_REGCOMP;
22c35a8c 4247 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 4248 rcop->op_first = scalar(expr);
131b3ad0
DM		 4249 rcop->op_flags |= OPf_KIDS
4250 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4251 | (reglist ? OPf_STACKED : 0);
79072805 4252 rcop->op_private = 1;
11343788 4253 rcop->op_other = o;
131b3ad0
DM		 4254 if (reglist)
4255 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4256
b5c19bd7 4257 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
ec192197 4258 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
79072805
LW		 4259
4260 /* establish postfix order */
3280af22 4261 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 4262 LINKLIST(expr);
4263 rcop->op_next = expr;
4264 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4265 }
4266 else {
4267 rcop->op_next = LINKLIST(expr);
4268 expr->op_next = (OP*)rcop;
4269 }
79072805 4270
2fcb4757 4271 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 4272 }
4273
4274 if (repl) {
748a9306 4275 OP *curop;
0244c3a4 4276 if (pm->op_pmflags & PMf_EVAL) {
6136c704 4277 curop = NULL;
670a9cb2
DM		 4278 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4279 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
0244c3a4 4280 }
748a9306
LW		 4281 else if (repl->op_type == OP_CONST)
4282 curop = repl;
79072805 4283 else {
c445ea15 4284 OP *lastop = NULL;
79072805 4285 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
e80b829c 4286 if (curop->op_type == OP_SCOPE
10250113 4287 || curop->op_type == OP_LEAVE
e80b829c 4288 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
79072805 4289 if (curop->op_type == OP_GV) {
6136c704 4290 GV * const gv = cGVOPx_gv(curop);
ce862d02 4291 repl_has_vars = 1;
f702bf4a 4292 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 4293 break;
4294 }
4295 else if (curop->op_type == OP_RV2CV)
4296 break;
4297 else if (curop->op_type == OP_RV2SV ||
4298 curop->op_type == OP_RV2AV ||
4299 curop->op_type == OP_RV2HV ||
4300 curop->op_type == OP_RV2GV) {
4301 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4302 break;
4303 }
748a9306
LW		 4304 else if (curop->op_type == OP_PADSV ||
4305 curop->op_type == OP_PADAV ||
4306 curop->op_type == OP_PADHV ||
e80b829c
RGS		 4307 curop->op_type == OP_PADANY)
4308 {
ce862d02 4309 repl_has_vars = 1;
748a9306 4310 }
1167e5da 4311 else if (curop->op_type == OP_PUSHRE)
6f207bd3 4312 NOOP; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 4313 else
4314 break;
4315 }
4316 lastop = curop;
4317 }
748a9306 4318 }
ce862d02 4319 if (curop == repl
e80b829c
RGS		 4320 && !(repl_has_vars
4321 && (!PM_GETRE(pm)
07bc277f 4322 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3be69782 4323 {
748a9306 4324 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2fcb4757 4325 op_prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 4326 }
4327 else {
aaa362c4 4328 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02 4329 pm->op_pmflags |= PMf_MAYBE_CONST;
ce862d02 4330 }
b7dc083c 4331 NewOp(1101, rcop, 1, LOGOP);
748a9306 4332 rcop->op_type = OP_SUBSTCONT;
22c35a8c 4333 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 4334 rcop->op_first = scalar(repl);
4335 rcop->op_flags |= OPf_KIDS;
4336 rcop->op_private = 1;
11343788 4337 rcop->op_other = o;
748a9306
LW		 4338
4339 /* establish postfix order */
4340 rcop->op_next = LINKLIST(repl);
4341 repl->op_next = (OP*)rcop;
4342
20e98b0f 4343 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
29f2e912
NC		 4344 assert(!(pm->op_pmflags & PMf_ONCE));
4345 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
748a9306 4346 rcop->op_next = 0;
79072805
LW		 4347 }
4348 }
4349
4350 return (OP*)pm;
4351}
4352
d67eb5f4
Z		 4353/*
4354=for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4355
4356Constructs, checks, and returns an op of any type that involves an
4357embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4358of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4359takes ownership of one reference to it.
4360
4361=cut
4362*/
4363
79072805 4364OP *
864dbfa3 4365Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 4366{
27da23d5 4367 dVAR;
79072805 4368 SVOP *svop;
7918f24d
NC		 4369
4370 PERL_ARGS_ASSERT_NEWSVOP;
4371
e69777c1
GG		 4372 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4373 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4374 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4375
b7dc083c 4376 NewOp(1101, svop, 1, SVOP);
eb160463 4377 svop->op_type = (OPCODE)type;
22c35a8c 4378 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 4379 svop->op_sv = sv;
4380 svop->op_next = (OP*)svop;
eb160463 4381 svop->op_flags = (U8)flags;
22c35a8c 4382 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 4383 scalar((OP*)svop);
22c35a8c 4384 if (PL_opargs[type] & OA_TARGET)
ed6116ce 4385 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 4386 return CHECKOP(type, svop);
79072805
LW		 4387}
4388
392d04bb 4389#ifdef USE_ITHREADS
d67eb5f4
Z		 4390
4391/*
4392=for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4393
4394Constructs, checks, and returns an op of any type that involves a
4395reference to a pad element. I<type> is the opcode. I<flags> gives the
4396eight bits of C<op_flags>. A pad slot is automatically allocated, and
4397is populated with I<sv>; this function takes ownership of one reference
4398to it.
4399
4400This function only exists if Perl has been compiled to use ithreads.
4401
4402=cut
4403*/
4404
79072805 4405OP *
350de78d
GS		 4406Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4407{
27da23d5 4408 dVAR;
350de78d 4409 PADOP *padop;
7918f24d
NC		 4410
4411 PERL_ARGS_ASSERT_NEWPADOP;
4412
e69777c1
GG		 4413 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4414 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4415 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4416
350de78d 4417 NewOp(1101, padop, 1, PADOP);
eb160463 4418 padop->op_type = (OPCODE)type;
350de78d
GS		 4419 padop->op_ppaddr = PL_ppaddr[type];
4420 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 4421 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4422 PAD_SETSV(padop->op_padix, sv);
58182927
NC		 4423 assert(sv);
4424 SvPADTMP_on(sv);
350de78d 4425 padop->op_next = (OP*)padop;
eb160463 4426 padop->op_flags = (U8)flags;
350de78d
GS		 4427 if (PL_opargs[type] & OA_RETSCALAR)
4428 scalar((OP*)padop);
4429 if (PL_opargs[type] & OA_TARGET)
4430 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4431 return CHECKOP(type, padop);
4432}
d67eb5f4
Z		 4433
4434#endif /* !USE_ITHREADS */
4435
4436/*
4437=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4438
4439Constructs, checks, and returns an op of any type that involves an
4440embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4441eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4442reference; calling this function does not transfer ownership of any
4443reference to it.
4444
4445=cut
4446*/
350de78d
GS		 4447
4448OP *
864dbfa3 4449Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 4450{
27da23d5 4451 dVAR;
7918f24d
NC		 4452
4453 PERL_ARGS_ASSERT_NEWGVOP;
4454
350de78d 4455#ifdef USE_ITHREADS
58182927 4456 GvIN_PAD_on(gv);
ff8997d7 4457 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 4458#else
ff8997d7 4459 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
350de78d 4460#endif
79072805
LW		 4461}
4462
d67eb5f4
Z		 4463/*
4464=for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4465
4466Constructs, checks, and returns an op of any type that involves an
4467embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4468the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4469must have been allocated using L</PerlMemShared_malloc>; the memory will
4470be freed when the op is destroyed.
4471
4472=cut
4473*/
4474
79072805 4475OP *
864dbfa3 4476Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 4477{
27da23d5 4478 dVAR;
79072805 4479 PVOP *pvop;
e69777c1
GG		 4480
4481 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4482 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4483
b7dc083c 4484 NewOp(1101, pvop, 1, PVOP);
eb160463 4485 pvop->op_type = (OPCODE)type;
22c35a8c 4486 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 4487 pvop->op_pv = pv;
4488 pvop->op_next = (OP*)pvop;
eb160463 4489 pvop->op_flags = (U8)flags;
22c35a8c 4490 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 4491 scalar((OP*)pvop);
22c35a8c 4492 if (PL_opargs[type] & OA_TARGET)
ed6116ce 4493 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 4494 return CHECKOP(type, pvop);
79072805
LW		 4495}
4496
eb8433b7
NC		 4497#ifdef PERL_MAD
4498OP*
4499#else
79072805 4500void
eb8433b7 4501#endif
864dbfa3 4502Perl_package(pTHX_ OP *o)
79072805 4503{
97aff369 4504 dVAR;
bf070237 4505 SV *const sv = cSVOPo->op_sv;
eb8433b7
NC		 4506#ifdef PERL_MAD
4507 OP *pegop;
4508#endif
79072805 4509
7918f24d
NC		 4510 PERL_ARGS_ASSERT_PACKAGE;
4511
03d9f026 4512 SAVEGENERICSV(PL_curstash);
3280af22 4513 save_item(PL_curstname);
de11ba31 4514
03d9f026 4515 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
e1a479c5 4516
bf070237 4517 sv_setsv(PL_curstname, sv);
de11ba31 4518
7ad382f4 4519 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 4520 PL_parser->copline = NOLINE;
4521 PL_parser->expect = XSTATE;
eb8433b7
NC		 4522
4523#ifndef PERL_MAD
4524 op_free(o);
4525#else
4526 if (!PL_madskills) {
4527 op_free(o);
1d866c12 4528 return NULL;
eb8433b7
NC		 4529 }
4530
4531 pegop = newOP(OP_NULL,0);
4532 op_getmad(o,pegop,'P');
4533 return pegop;
4534#endif
79072805
LW		 4535}
4536
6fa4d285
DG		 4537void
4538Perl_package_version( pTHX_ OP *v )
4539{
4540 dVAR;
458818ec 4541 U32 savehints = PL_hints;
6fa4d285 4542 PERL_ARGS_ASSERT_PACKAGE_VERSION;
458818ec 4543 PL_hints &= ~HINT_STRICT_VARS;
e92f586b 4544 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
458818ec 4545 PL_hints = savehints;
6fa4d285
DG		 4546 op_free(v);
4547}
4548
eb8433b7
NC		 4549#ifdef PERL_MAD
4550OP*
4551#else
85e6fe83 4552void
eb8433b7 4553#endif
88d95a4d 4554Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 4555{
97aff369 4556 dVAR;
a0d0e21e 4557 OP *pack;
a0d0e21e 4558 OP *imop;
b1cb66bf 4559 OP *veop;
eb8433b7
NC		 4560#ifdef PERL_MAD
4561 OP *pegop = newOP(OP_NULL,0);
4562#endif
88e9444c 4563 SV *use_version = NULL;
85e6fe83 4564
7918f24d
NC		 4565 PERL_ARGS_ASSERT_UTILIZE;
4566
88d95a4d 4567 if (idop->op_type != OP_CONST)
cea2e8a9 4568 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 4569
eb8433b7
NC		 4570 if (PL_madskills)
4571 op_getmad(idop,pegop,'U');
4572
5f66b61c 4573 veop = NULL;
b1cb66bf 4574
aec46f14 4575 if (version) {
551405c4 4576 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 4577
eb8433b7
NC		 4578 if (PL_madskills)
4579 op_getmad(version,pegop,'V');
aec46f14 4580 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 4581 arg = version;
4582 }
4583 else {
4584 OP *pack;
0f79a09d 4585 SV *meth;
b1cb66bf 4586
44dcb63b 4587 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
fe13d51d 4588 Perl_croak(aTHX_ "Version number must be a constant number");
b1cb66bf 4589
88d95a4d
JH		 4590 /* Make copy of idop so we don't free it twice */
4591 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 4592
4593 /* Fake up a method call to VERSION */
18916d0d 4594 meth = newSVpvs_share("VERSION");
b1cb66bf 4595 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2fcb4757
Z		 4596 op_append_elem(OP_LIST,
4597 op_prepend_elem(OP_LIST, pack, list(version)),
0f79a09d 4598 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 4599 }
4600 }
aeea060c 4601
a0d0e21e 4602 /* Fake up an import/unimport */
eb8433b7
NC		 4603 if (arg && arg->op_type == OP_STUB) {
4604 if (PL_madskills)
4605 op_getmad(arg,pegop,'S');
4633a7c4 4606 imop = arg; /* no import on explicit () */
eb8433b7 4607 }
88d95a4d 4608 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 4609 imop = NULL; /* use 5.0; */
88e9444c
NC		 4610 if (aver)
4611 use_version = ((SVOP*)idop)->op_sv;
4612 else
468aa647 4613 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 4614 }
4633a7c4 4615 else {
0f79a09d
GS		 4616 SV *meth;
4617
eb8433b7
NC		 4618 if (PL_madskills)
4619 op_getmad(arg,pegop,'A');
4620
88d95a4d
JH		 4621 /* Make copy of idop so we don't free it twice */
4622 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 4623
4624 /* Fake up a method call to import/unimport */
427d62a4 4625 meth = aver
18916d0d 4626 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 4627 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2fcb4757
Z		 4628 op_append_elem(OP_LIST,
4629 op_prepend_elem(OP_LIST, pack, list(arg)),
0f79a09d 4630 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 4631 }
4632
a0d0e21e 4633 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 4634 newATTRSUB(floor,
18916d0d 4635 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL		 4636 NULL,
4637 NULL,
2fcb4757
Z		 4638 op_append_elem(OP_LINESEQ,
4639 op_append_elem(OP_LINESEQ,
bd61b366
SS		 4640 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4641 newSTATEOP(0, NULL, veop)),
4642 newSTATEOP(0, NULL, imop) ));
85e6fe83 4643
88e9444c
NC		 4644 if (use_version) {
4645 /* If we request a version >= 5.9.5, load feature.pm with the
4646 * feature bundle that corresponds to the required version. */
4647 use_version = sv_2mortal(new_version(use_version));
4648
4649 if (vcmp(use_version,
4650 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4651 SV *const importsv = vnormal(use_version);
4652 *SvPVX_mutable(importsv) = ':';
4653 ENTER_with_name("load_feature");
4654 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4655 LEAVE_with_name("load_feature");
4656 }
4657 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4658 if (vcmp(use_version,
4659 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4660 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4661 }
4662 }
4663
70f5e4ed
JH		 4664 /* The "did you use incorrect case?" warning used to be here.
4665 * The problem is that on case-insensitive filesystems one
4666 * might get false positives for "use" (and "require"):
4667 * "use Strict" or "require CARP" will work. This causes
4668 * portability problems for the script: in case-strict
4669 * filesystems the script will stop working.
4670 *
4671 * The "incorrect case" warning checked whether "use Foo"
4672 * imported "Foo" to your namespace, but that is wrong, too:
4673 * there is no requirement nor promise in the language that
4674 * a Foo.pm should or would contain anything in package "Foo".
4675 *
4676 * There is very little Configure-wise that can be done, either:
4677 * the case-sensitivity of the build filesystem of Perl does not
4678 * help in guessing the case-sensitivity of the runtime environment.
4679 */
18fc9488 4680
c305c6a0 4681 PL_hints |= HINT_BLOCK_SCOPE;
53a7735b
DM		 4682 PL_parser->copline = NOLINE;
4683 PL_parser->expect = XSTATE;
8ec8fbef 4684 PL_cop_seqmax++; /* Purely for B::*'s benefit */
6012dc80
DM		 4685 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4686 PL_cop_seqmax++;
eb8433b7
NC		 4687
4688#ifdef PERL_MAD
4689 if (!PL_madskills) {
4690 /* FIXME - don't allocate pegop if !PL_madskills */
4691 op_free(pegop);
1d866c12 4692 return NULL;
eb8433b7
NC		 4693 }
4694 return pegop;
4695#endif
85e6fe83
LW		 4696}
4697
7d3fb230 4698/*
ccfc67b7
JH		 4699=head1 Embedding Functions
4700
7d3fb230
BS		 4701=for apidoc load_module
4702
4703Loads the module whose name is pointed to by the string part of name.
4704Note that the actual module name, not its filename, should be given.
4705Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4706PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4707(or 0 for no flags). ver, if specified, provides version semantics
4708similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4709arguments can be used to specify arguments to the module's import()
76f108ac
JD		 4710method, similar to C<use Foo::Bar VERSION LIST>. They must be
4711terminated with a final NULL pointer. Note that this list can only
4712be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4713Otherwise at least a single NULL pointer to designate the default
4714import list is required.
7d3fb230
BS		 4715
4716=cut */
4717
e4783991
GS		 4718void
4719Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4720{
4721 va_list args;
7918f24d
NC		 4722
4723 PERL_ARGS_ASSERT_LOAD_MODULE;
4724
e4783991
GS		 4725 va_start(args, ver);
4726 vload_module(flags, name, ver, &args);
4727 va_end(args);
4728}
4729
4730#ifdef PERL_IMPLICIT_CONTEXT
4731void
4732Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4733{
4734 dTHX;
4735 va_list args;
7918f24d 4736 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
e4783991
GS		 4737 va_start(args, ver);
4738 vload_module(flags, name, ver, &args);
4739 va_end(args);
4740}
4741#endif
4742
4743void
4744Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4745{
97aff369 4746 dVAR;
551405c4 4747 OP *veop, *imop;
551405c4 4748 OP * const modname = newSVOP(OP_CONST, 0, name);
7918f24d
NC		 4749
4750 PERL_ARGS_ASSERT_VLOAD_MODULE;
4751
e4783991
GS		 4752 modname->op_private |= OPpCONST_BARE;
4753 if (ver) {
4754 veop = newSVOP(OP_CONST, 0, ver);
4755 }
4756 else
5f66b61c 4757 veop = NULL;
e4783991
GS		 4758 if (flags & PERL_LOADMOD_NOIMPORT) {
4759 imop = sawparens(newNULLLIST());
4760 }
4761 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4762 imop = va_arg(*args, OP*);
4763 }
4764 else {
4765 SV *sv;
5f66b61c 4766 imop = NULL;
e4783991
GS		 4767 sv = va_arg(*args, SV*);
4768 while (sv) {
2fcb4757 4769 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
e4783991
GS		 4770 sv = va_arg(*args, SV*);
4771 }
4772 }
81885997 4773
53a7735b
DM		 4774 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4775 * that it has a PL_parser to play with while doing that, and also
4776 * that it doesn't mess with any existing parser, by creating a tmp
4777 * new parser with lex_start(). This won't actually be used for much,
4778 * since pp_require() will create another parser for the real work. */
4779
4780 ENTER;
4781 SAVEVPTR(PL_curcop);
27fcb6ee 4782 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
53a7735b
DM		 4783 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4784 veop, modname, imop);
4785 LEAVE;
e4783991
GS		 4786}
4787
79072805 4788OP *
850e8516 4789Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 4790{
97aff369 4791 dVAR;
78ca652e 4792 OP *doop;
a0714e2c 4793 GV *gv = NULL;
78ca652e 4794
7918f24d
NC		 4795 PERL_ARGS_ASSERT_DOFILE;
4796
850e8516 4797 if (!force_builtin) {
fafc274c 4798 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
850e8516 4799 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 4800 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
a0714e2c 4801 gv = gvp ? *gvp : NULL;
850e8516
RGS		 4802 }
4803 }
78ca652e 4804
b9f751c0 4805 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e 4806 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 4807 op_append_elem(OP_LIST, term,
78ca652e 4808 scalar(newUNOP(OP_RV2CV, 0,
d4c19fe8 4809 newGVOP(OP_GV, 0, gv))))));
78ca652e
GS		 4810 }
4811 else {
4812 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4813 }
4814 return doop;
4815}
4816
d67eb5f4
Z		 4817/*
4818=head1 Optree construction
4819
4820=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4821
4822Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4823gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4824be set automatically, and, shifted up eight bits, the eight bits of
4825C<op_private>, except that the bit with value 1 or 2 is automatically
4826set as required. I<listval> and I<subscript> supply the parameters of
4827the slice; they are consumed by this function and become part of the
4828constructed op tree.
4829
4830=cut
4831*/
4832
78ca652e 4833OP *
864dbfa3 4834Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 4835{
4836 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 4837 list(force_list(subscript)),
4838 list(force_list(listval)) );
79072805
LW		 4839}
4840
76e3520e 4841STATIC I32
504618e9 4842S_is_list_assignment(pTHX_ register const OP *o)
79072805 4843{
1496a290
AL		 4844 unsigned type;
4845 U8 flags;
4846
11343788 4847 if (!o)
79072805
LW		 4848 return TRUE;
4849
1496a290 4850 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
11343788 4851 o = cUNOPo->op_first;
79072805 4852
1496a290
AL		 4853 flags = o->op_flags;
4854 type = o->op_type;
4855 if (type == OP_COND_EXPR) {
504618e9
AL		 4856 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4857 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 4858
4859 if (t && f)
4860 return TRUE;
4861 if (t || f)
4862 yyerror("Assignment to both a list and a scalar");
4863 return FALSE;
4864 }
4865
1496a290
AL		 4866 if (type == OP_LIST &&
4867 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
95f0a2f1
SB		 4868 o->op_private & OPpLVAL_INTRO)
4869 return FALSE;
4870
1496a290
AL		 4871 if (type == OP_LIST || flags & OPf_PARENS ||
4872 type == OP_RV2AV || type == OP_RV2HV ||
4873 type == OP_ASLICE || type == OP_HSLICE)
79072805
LW		 4874 return TRUE;
4875
1496a290 4876 if (type == OP_PADAV || type == OP_PADHV)
93a17b20
LW		 4877 return TRUE;
4878
1496a290 4879 if (type == OP_RV2SV)
79072805
LW		 4880 return FALSE;
4881
4882 return FALSE;
4883}
4884
d67eb5f4 4885/*
83f9fced
GG		 4886 Helper function for newASSIGNOP to detection commonality between the
4887 lhs and the rhs. Marks all variables with PL_generation. If it
4888 returns TRUE the assignment must be able to handle common variables.
4889*/
4890PERL_STATIC_INLINE bool
4891S_aassign_common_vars(pTHX_ OP* o)
4892{
83f9fced 4893 OP *curop;
3023b5f3 4894 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
83f9fced
GG		 4895 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4896 if (curop->op_type == OP_GV) {
4897 GV *gv = cGVOPx_gv(curop);
4898 if (gv == PL_defgv
4899 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4900 return TRUE;
4901 GvASSIGN_GENERATION_set(gv, PL_generation);
4902 }
4903 else if (curop->op_type == OP_PADSV ||
4904 curop->op_type == OP_PADAV ||
4905 curop->op_type == OP_PADHV ||
4906 curop->op_type == OP_PADANY)
4907 {
4908 if (PAD_COMPNAME_GEN(curop->op_targ)
4909 == (STRLEN)PL_generation)
4910 return TRUE;
4911 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4912
4913 }
4914 else if (curop->op_type == OP_RV2CV)
4915 return TRUE;
4916 else if (curop->op_type == OP_RV2SV ||
4917 curop->op_type == OP_RV2AV ||
4918 curop->op_type == OP_RV2HV ||
4919 curop->op_type == OP_RV2GV) {
3023b5f3 4920 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
83f9fced
GG		 4921 return TRUE;
4922 }
4923 else if (curop->op_type == OP_PUSHRE) {
4924#ifdef USE_ITHREADS
4925 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4926 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4927 if (gv == PL_defgv
4928 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4929 return TRUE;
4930 GvASSIGN_GENERATION_set(gv, PL_generation);
4931 }
4932#else
4933 GV *const gv
4934 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4935 if (gv) {
4936 if (gv == PL_defgv
4937 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4938 return TRUE;
4939 GvASSIGN_GENERATION_set(gv, PL_generation);
4940 }
4941#endif
4942 }
4943 else
4944 return TRUE;
4945 }
3023b5f3
GG		 4946
4947 if (curop->op_flags & OPf_KIDS) {
4948 if (aassign_common_vars(curop))
4949 return TRUE;
4950 }
83f9fced
GG		 4951 }
4952 return FALSE;
4953}
4954
4955/*
d67eb5f4
Z		 4956=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4957
4958Constructs, checks, and returns an assignment op. I<left> and I<right>
4959supply the parameters of the assignment; they are consumed by this
4960function and become part of the constructed op tree.
4961
4962If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4963a suitable conditional optree is constructed. If I<optype> is the opcode
4964of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4965performs the binary operation and assigns the result to the left argument.
4966Either way, if I<optype> is non-zero then I<flags> has no effect.
4967
4968If I<optype> is zero, then a plain scalar or list assignment is
4969constructed. Which type of assignment it is is automatically determined.
4970I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4971will be set automatically, and, shifted up eight bits, the eight bits
4972of C<op_private>, except that the bit with value 1 or 2 is automatically
4973set as required.
4974
4975=cut
4976*/
4977
79072805 4978OP *
864dbfa3 4979Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 4980{
97aff369 4981 dVAR;
11343788 4982 OP *o;
79072805 4983
a0d0e21e 4984 if (optype) {
c963b151 4985 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e 4986 return newLOGOP(optype, 0,
3ad73efd 4987 op_lvalue(scalar(left), optype),
a0d0e21e
LW		 4988 newUNOP(OP_SASSIGN, 0, scalar(right)));
4989 }
4990 else {
4991 return newBINOP(optype, OPf_STACKED,
3ad73efd 4992 op_lvalue(scalar(left), optype), scalar(right));
a0d0e21e
LW		 4993 }
4994 }
4995
504618e9 4996 if (is_list_assignment(left)) {
6dbe9451
NC		 4997 static const char no_list_state[] = "Initialization of state variables"
4998 " in list context currently forbidden";
10c8fecd 4999 OP *curop;
fafafbaf 5000 bool maybe_common_vars = TRUE;
10c8fecd 5001
3280af22 5002 PL_modcount = 0;
3ad73efd 5003 left = op_lvalue(left, OP_AASSIGN);
10c8fecd
GS		 5004 curop = list(force_list(left));
5005 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 5006 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4 5007
fafafbaf
RD		 5008 if ((left->op_type == OP_LIST
5009 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5010 {
5011 OP* lop = ((LISTOP*)left)->op_first;
5012 maybe_common_vars = FALSE;
5013 while (lop) {
5014 if (lop->op_type == OP_PADSV ||
5015 lop->op_type == OP_PADAV ||
5016 lop->op_type == OP_PADHV ||
5017 lop->op_type == OP_PADANY) {
5018 if (!(lop->op_private & OPpLVAL_INTRO))
5019 maybe_common_vars = TRUE;
5020
5021 if (lop->op_private & OPpPAD_STATE) {
5022 if (left->op_private & OPpLVAL_INTRO) {
5023 /* Each variable in state($a, $b, $c) = ... */
5024 }
5025 else {
5026 /* Each state variable in
5027 (state $a, my $b, our $c, $d, undef) = ... */
5028 }
5029 yyerror(no_list_state);
5030 } else {
5031 /* Each my variable in
5032 (state $a, my $b, our $c, $d, undef) = ... */
5033 }
5034 } else if (lop->op_type == OP_UNDEF ||
5035 lop->op_type == OP_PUSHMARK) {
5036 /* undef may be interesting in
5037 (state $a, undef, state $c) */
5038 } else {
5039 /* Other ops in the list. */
5040 maybe_common_vars = TRUE;
5041 }
5042 lop = lop->op_sibling;
5043 }
5044 }
5045 else if ((left->op_private & OPpLVAL_INTRO)
5046 && ( left->op_type == OP_PADSV
5047 || left->op_type == OP_PADAV
5048 || left->op_type == OP_PADHV
5049 || left->op_type == OP_PADANY))
5050 {
0f907b96 5051 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
fafafbaf
RD		 5052 if (left->op_private & OPpPAD_STATE) {
5053 /* All single variable list context state assignments, hence
5054 state ($a) = ...
5055 (state $a) = ...
5056 state @a = ...
5057 state (@a) = ...
5058 (state @a) = ...
5059 state %a = ...
5060 state (%a) = ...
5061 (state %a) = ...
5062 */
5063 yyerror(no_list_state);
5064 }
5065 }
5066
dd2155a4
DM		 5067 /* PL_generation sorcery:
5068 * an assignment like ($a,$b) = ($c,$d) is easier than
5069 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5070 * To detect whether there are common vars, the global var
5071 * PL_generation is incremented for each assign op we compile.
5072 * Then, while compiling the assign op, we run through all the
5073 * variables on both sides of the assignment, setting a spare slot
5074 * in each of them to PL_generation. If any of them already have
5075 * that value, we know we've got commonality. We could use a
5076 * single bit marker, but then we'd have to make 2 passes, first
5077 * to clear the flag, then to test and set it. To find somewhere
931b58fb 5078 * to store these values, evil chicanery is done with SvUVX().
dd2155a4
DM		 5079 */
5080
fafafbaf 5081 if (maybe_common_vars) {
3280af22 5082 PL_generation++;
83f9fced 5083 if (aassign_common_vars(o))
10c8fecd 5084 o->op_private |= OPpASSIGN_COMMON;
3023b5f3 5085 LINKLIST(o);
461824dc 5086 }
9fdc7570 5087
e9cc17ba 5088 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
1496a290
AL		 5089 OP* tmpop = ((LISTOP*)right)->op_first;
5090 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
551405c4 5091 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 5092 if (left->op_type == OP_RV2AV &&
5093 !(left->op_private & OPpLVAL_INTRO) &&
11343788 5094 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 5095 {
5096 tmpop = ((UNOP*)left)->op_first;
20e98b0f
NC		 5097 if (tmpop->op_type == OP_GV
5098#ifdef USE_ITHREADS
5099 && !pm->op_pmreplrootu.op_pmtargetoff
5100#else
5101 && !pm->op_pmreplrootu.op_pmtargetgv
5102#endif
5103 ) {
971a9dd3 5104#ifdef USE_ITHREADS
20e98b0f
NC		 5105 pm->op_pmreplrootu.op_pmtargetoff
5106 = cPADOPx(tmpop)->op_padix;
971a9dd3
GS		 5107 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5108#else
20e98b0f 5109 pm->op_pmreplrootu.op_pmtargetgv
159b6efe 5110 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
a0714e2c 5111 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 5112#endif
c07a80fd 5113 pm->op_pmflags |= PMf_ONCE;
11343788 5114 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 5115 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 5116 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 5117 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 5118 op_free(o); /* blow off assign */
54310121 5119 right->op_flags &= ~OPf_WANT;
a5f75d66 5120 /* "I don't know and I don't care." */
c07a80fd 5121 return right;
5122 }
5123 }
5124 else {
e6438c1a 5125 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 5126 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5127 {
5128 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
b8de32d5 5129 if (SvIOK(sv) && SvIVX(sv) == 0)
3280af22 5130 sv_setiv(sv, PL_modcount+1);
c07a80fd 5131 }
5132 }
5133 }
5134 }
11343788 5135 return o;
79072805
LW		 5136 }
5137 if (!right)
5138 right = newOP(OP_UNDEF, 0);
5139 if (right->op_type == OP_READLINE) {
5140 right->op_flags |= OPf_STACKED;
3ad73efd
Z		 5141 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5142 scalar(right));
79072805 5143 }
a0d0e21e 5144 else {
11343788 5145 o = newBINOP(OP_SASSIGN, flags,
3ad73efd 5146 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
a0d0e21e 5147 }
11343788 5148 return o;
79072805
LW		 5149}
5150
d67eb5f4
Z		 5151/*
5152=for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5153
5154Constructs a state op (COP). The state op is normally a C<nextstate> op,
5155but will be a C<dbstate> op if debugging is enabled for currently-compiled
5156code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5157If I<label> is non-null, it supplies the name of a label to attach to
5158the state op; this function takes ownership of the memory pointed at by
5159I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5160for the state op.
5161
5162If I<o> is null, the state op is returned. Otherwise the state op is
5163combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5164is consumed by this function and becomes part of the returned op tree.
5165
5166=cut
5167*/
5168
79072805 5169OP *
864dbfa3 5170Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 5171{
27da23d5 5172 dVAR;
e1ec3a88 5173 const U32 seq = intro_my();
79072805
LW		 5174 register COP *cop;
5175
b7dc083c 5176 NewOp(1101, cop, 1, COP);
57843af0 5177 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 5178 cop->op_type = OP_DBSTATE;
22c35a8c 5179 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 5180 }
5181 else {
5182 cop->op_type = OP_NEXTSTATE;
22c35a8c 5183 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 5184 }
eb160463 5185 cop->op_flags = (U8)flags;
623e6609 5186 CopHINTS_set(cop, PL_hints);
ff0cee69 5187#ifdef NATIVE_HINTS
5188 cop->op_private |= NATIVE_HINTS;
5189#endif
623e6609 5190 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 5191 cop->op_next = (OP*)cop;
5192
bbce6d69 5193 cop->cop_seq = seq;
72dc9ed5 5194 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
20439bc7 5195 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
dca6062a 5196 if (label) {
aebc0cbe 5197 Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
dca6062a
NC		 5198
5199 PL_hints |= HINT_BLOCK_SCOPE;
5200 /* It seems that we need to defer freeing this pointer, as other parts
5201 of the grammar end up wanting to copy it after this op has been
5202 created. */
5203 SAVEFREEPV(label);
dca6062a 5204 }
79072805 5205
53a7735b 5206 if (PL_parser && PL_parser->copline == NOLINE)
57843af0 5207 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 5208 else {
53a7735b
DM		 5209 CopLINE_set(cop, PL_parser->copline);
5210 if (PL_parser)
5211 PL_parser->copline = NOLINE;
79072805 5212 }
57843af0 5213#ifdef USE_ITHREADS
f4dd75d9 5214 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 5215#else
f4dd75d9 5216 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 5217#endif
11faa288 5218 CopSTASH_set(cop, PL_curstash);
79072805 5219
65269a95
TB		 5220 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5221 /* this line can have a breakpoint - store the cop in IV */
80a702cd
RGS		 5222 AV *av = CopFILEAVx(PL_curcop);
5223 if (av) {
5224 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5225 if (svp && *svp != &PL_sv_undef ) {
5226 (void)SvIOK_on(*svp);
5227 SvIV_set(*svp, PTR2IV(cop));
5228 }
1eb1540c 5229 }
93a17b20
LW		 5230 }
5231
f6f3a1fe
RGS		 5232 if (flags & OPf_SPECIAL)
5233 op_null((OP*)cop);
2fcb4757 5234 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 5235}
5236
d67eb5f4
Z		 5237/*
5238=for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5239
5240Constructs, checks, and returns a logical (flow control) op. I<type>
5241is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5242that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5243the eight bits of C<op_private>, except that the bit with value 1 is
5244automatically set. I<first> supplies the expression controlling the
5245flow, and I<other> supplies the side (alternate) chain of ops; they are
5246consumed by this function and become part of the constructed op tree.
5247
5248=cut
5249*/
bbce6d69 5250
79072805 5251OP *
864dbfa3 5252Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 5253{
27da23d5 5254 dVAR;
7918f24d
NC		 5255
5256 PERL_ARGS_ASSERT_NEWLOGOP;
5257
883ffac3
CS		 5258 return new_logop(type, flags, &first, &other);
5259}
5260
3bd495df 5261STATIC OP *
71c4dbc3
VP		 5262S_search_const(pTHX_ OP *o)
5263{
5264 PERL_ARGS_ASSERT_SEARCH_CONST;
5265
5266 switch (o->op_type) {
5267 case OP_CONST:
5268 return o;
5269 case OP_NULL:
5270 if (o->op_flags & OPf_KIDS)
5271 return search_const(cUNOPo->op_first);
5272 break;
5273 case OP_LEAVE:
5274 case OP_SCOPE:
5275 case OP_LINESEQ:
5276 {
5277 OP *kid;
5278 if (!(o->op_flags & OPf_KIDS))
5279 return NULL;
5280 kid = cLISTOPo->op_first;
5281 do {
5282 switch (kid->op_type) {
5283 case OP_ENTER:
5284 case OP_NULL:
5285 case OP_NEXTSTATE:
5286 kid = kid->op_sibling;
5287 break;
5288 default:
5289 if (kid != cLISTOPo->op_last)
5290 return NULL;
5291 goto last;
5292 }
5293 } while (kid);
5294 if (!kid)
5295 kid = cLISTOPo->op_last;
5296last:
5297 return search_const(kid);
5298 }
5299 }
5300
5301 return NULL;
5302}
5303
5304STATIC OP *
cea2e8a9 5305S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 5306{
27da23d5 5307 dVAR;
79072805 5308 LOGOP *logop;
11343788 5309 OP *o;
71c4dbc3
VP		 5310 OP *first;
5311 OP *other;
5312 OP *cstop = NULL;
edbe35ea 5313 int prepend_not = 0;
79072805 5314
7918f24d
NC		 5315 PERL_ARGS_ASSERT_NEW_LOGOP;
5316
71c4dbc3
VP		 5317 first = *firstp;
5318 other = *otherp;
5319
a0d0e21e
LW		 5320 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5321 return newBINOP(type, flags, scalar(first), scalar(other));
5322
e69777c1
GG		 5323 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5324
8990e307 5325 scalarboolean(first);
edbe35ea 5326 /* optimize AND and OR ops that have NOTs as children */
68726e16 5327 if (first->op_type == OP_NOT
b6214b80 5328 && (first->op_flags & OPf_KIDS)
edbe35ea
VP		 5329 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5330 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
b6214b80 5331 && !PL_madskills) {
79072805
LW		 5332 if (type == OP_AND || type == OP_OR) {
5333 if (type == OP_AND)
5334 type = OP_OR;
5335 else
5336 type = OP_AND;
07f3cdf5 5337 op_null(first);
edbe35ea 5338 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
07f3cdf5 5339 op_null(other);
edbe35ea
VP		 5340 prepend_not = 1; /* prepend a NOT op later */
5341 }
79072805
LW		 5342 }
5343 }
71c4dbc3
VP		 5344 /* search for a constant op that could let us fold the test */
5345 if ((cstop = search_const(first))) {
5346 if (cstop->op_private & OPpCONST_STRICT)
5347 no_bareword_allowed(cstop);
a2a5de95
NC		 5348 else if ((cstop->op_private & OPpCONST_BARE))
5349 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
71c4dbc3
VP		 5350 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5351 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5352 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5f66b61c 5353 *firstp = NULL;
d6fee5c7
DM		 5354 if (other->op_type == OP_CONST)
5355 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 5356 if (PL_madskills) {
5357 OP *newop = newUNOP(OP_NULL, 0, other);
5358 op_getmad(first, newop, '1');
5359 newop->op_targ = type; /* set "was" field */
5360 return newop;
5361 }
5362 op_free(first);
dd3e51dc
VP		 5363 if (other->op_type == OP_LEAVE)
5364 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
2474a784
FC		 5365 else if (other->op_type == OP_MATCH
5366 || other->op_type == OP_SUBST
bb16bae8 5367 || other->op_type == OP_TRANSR
2474a784
FC		 5368 || other->op_type == OP_TRANS)
5369 /* Mark the op as being unbindable with =~ */
5370 other->op_flags |= OPf_SPECIAL;
79072805
LW		 5371 return other;
5372 }
5373 else {
7921d0f2 5374 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 5375 const OP *o2 = other;
7921d0f2
DM		 5376 if ( ! (o2->op_type == OP_LIST
5377 && (( o2 = cUNOPx(o2)->op_first))
5378 && o2->op_type == OP_PUSHMARK
5379 && (( o2 = o2->op_sibling)) )
5380 )
5381 o2 = other;
5382 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5383 || o2->op_type == OP_PADHV)
5384 && o2->op_private & OPpLVAL_INTRO
a2a5de95 5385 && !(o2->op_private & OPpPAD_STATE))
7921d0f2 5386 {
d1d15184
NC		 5387 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5388 "Deprecated use of my() in false conditional");
7921d0f2
DM		 5389 }
5390
5f66b61c 5391 *otherp = NULL;
d6fee5c7
DM		 5392 if (first->op_type == OP_CONST)
5393 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 5394 if (PL_madskills) {
5395 first = newUNOP(OP_NULL, 0, first);
5396 op_getmad(other, first, '2');
5397 first->op_targ = type; /* set "was" field */
5398 }
5399 else
5400 op_free(other);
79072805
LW		 5401 return first;
5402 }
5403 }
041457d9
DM		 5404 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5405 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 5406 {
b22e6366
AL		 5407 const OP * const k1 = ((UNOP*)first)->op_first;
5408 const OP * const k2 = k1->op_sibling;
a6006777 5409 OPCODE warnop = 0;
5410 switch (first->op_type)
5411 {
5412 case OP_NULL:
5413 if (k2 && k2->op_type == OP_READLINE
5414 && (k2->op_flags & OPf_STACKED)
1c846c1f 5415 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 5416 {
a6006777 5417 warnop = k2->op_type;
72b16652 5418 }
a6006777 5419 break;
5420
5421 case OP_SASSIGN:
68dc0745 5422 if (k1->op_type == OP_READDIR
5423 || k1->op_type == OP_GLOB
72b16652 5424 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 5425 || k1->op_type == OP_EACH
5426 || k1->op_type == OP_AEACH)
72b16652
GS		 5427 {
5428 warnop = ((k1->op_type == OP_NULL)
eb160463 5429 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 5430 }
a6006777 5431 break;
5432 }
8ebc5c01 5433 if (warnop) {
6867be6d 5434 const line_t oldline = CopLINE(PL_curcop);
53a7735b 5435 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 5436 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 5437 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 5438 PL_op_desc[warnop],
68dc0745 5439 ((warnop == OP_READLINE || warnop == OP_GLOB)
5440 ? " construct" : "() operator"));
57843af0 5441 CopLINE_set(PL_curcop, oldline);
8ebc5c01 5442 }
a6006777 5443 }
79072805
LW		 5444
5445 if (!other)
5446 return first;
5447
c963b151 5448 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 5449 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5450
b7dc083c 5451 NewOp(1101, logop, 1, LOGOP);
79072805 5452
eb160463 5453 logop->op_type = (OPCODE)type;
22c35a8c 5454 logop->op_ppaddr = PL_ppaddr[type];
79072805 5455 logop->op_first = first;
585ec06d 5456 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 5457 logop->op_other = LINKLIST(other);
eb160463 5458 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 5459
5460 /* establish postfix order */
5461 logop->op_next = LINKLIST(first);
5462 first->op_next = (OP*)logop;
5463 first->op_sibling = other;
5464
463d09e6
RGS		 5465 CHECKOP(type,logop);
5466
edbe35ea 5467 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
11343788 5468 other->op_next = o;
79072805 5469
11343788 5470 return o;
79072805
LW		 5471}
5472
d67eb5f4
Z		 5473/*
5474=for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5475
5476Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5477op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5478will be set automatically, and, shifted up eight bits, the eight bits of
5479C<op_private>, except that the bit with value 1 is automatically set.
5480I<first> supplies the expression selecting between the two branches,
5481and I<trueop> and I<falseop> supply the branches; they are consumed by
5482this function and become part of the constructed op tree.
5483
5484=cut
5485*/
5486
79072805 5487OP *
864dbfa3 5488Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 5489{
27da23d5 5490 dVAR;
1a67a97c
SM		 5491 LOGOP *logop;
5492 OP *start;
11343788 5493 OP *o;
71c4dbc3 5494 OP *cstop;
79072805 5495
7918f24d
NC		 5496 PERL_ARGS_ASSERT_NEWCONDOP;
5497
b1cb66bf 5498 if (!falseop)
5499 return newLOGOP(OP_AND, 0, first, trueop);
5500 if (!trueop)
5501 return newLOGOP(OP_OR, 0, first, falseop);
79072805 5502
8990e307 5503 scalarboolean(first);
71c4dbc3 5504 if ((cstop = search_const(first))) {
5b6782b2 5505 /* Left or right arm of the conditional? */
71c4dbc3 5506 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5b6782b2
NC		 5507 OP *live = left ? trueop : falseop;
5508 OP *const dead = left ? falseop : trueop;
71c4dbc3
VP		 5509 if (cstop->op_private & OPpCONST_BARE &&
5510 cstop->op_private & OPpCONST_STRICT) {
5511 no_bareword_allowed(cstop);
b22e6366 5512 }
5b6782b2
NC		 5513 if (PL_madskills) {
5514 /* This is all dead code when PERL_MAD is not defined. */
5515 live = newUNOP(OP_NULL, 0, live);
5516 op_getmad(first, live, 'C');
5517 op_getmad(dead, live, left ? 'e' : 't');
5518 } else {
5519 op_free(first);
5520 op_free(dead);
79072805 5521 }
ef9da979
FC		 5522 if (live->op_type == OP_LEAVE)
5523 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
2474a784 5524 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
bb16bae8 5525 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
2474a784
FC		 5526 /* Mark the op as being unbindable with =~ */
5527 live->op_flags |= OPf_SPECIAL;
5b6782b2 5528 return live;
79072805 5529 }
1a67a97c
SM		 5530 NewOp(1101, logop, 1, LOGOP);
5531 logop->op_type = OP_COND_EXPR;
5532 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5533 logop->op_first = first;
585ec06d 5534 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 5535 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 5536 logop->op_other = LINKLIST(trueop);
5537 logop->op_next = LINKLIST(falseop);
79072805 5538
463d09e6
RGS		 5539 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5540 logop);
79072805
LW		 5541
5542 /* establish postfix order */
1a67a97c
SM		 5543 start = LINKLIST(first);
5544 first->op_next = (OP*)logop;
79072805 5545
b1cb66bf 5546 first->op_sibling = trueop;
5547 trueop->op_sibling = falseop;
1a67a97c 5548 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 5549
1a67a97c 5550 trueop->op_next = falseop->op_next = o;
79072805 5551
1a67a97c 5552 o->op_next = start;
11343788 5553 return o;
79072805
LW		 5554}
5555
d67eb5f4
Z		 5556/*
5557=for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5558
5559Constructs and returns a C<range> op, with subordinate C<flip> and
5560C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5561C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5562for both the C<flip> and C<range> ops, except that the bit with value
55631 is automatically set. I<left> and I<right> supply the expressions
5564controlling the endpoints of the range; they are consumed by this function
5565and become part of the constructed op tree.
5566
5567=cut
5568*/
5569
79072805 5570OP *
864dbfa3 5571Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 5572{
27da23d5 5573 dVAR;
1a67a97c 5574 LOGOP *range;
79072805
LW		 5575 OP *flip;
5576 OP *flop;
1a67a97c 5577 OP *leftstart;
11343788 5578 OP *o;
79072805 5579
7918f24d
NC		 5580 PERL_ARGS_ASSERT_NEWRANGE;
5581
1a67a97c 5582 NewOp(1101, range, 1, LOGOP);
79072805 5583
1a67a97c
SM		 5584 range->op_type = OP_RANGE;
5585 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5586 range->op_first = left;
5587 range->op_flags = OPf_KIDS;
5588 leftstart = LINKLIST(left);
5589 range->op_other = LINKLIST(right);
eb160463 5590 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 5591
5592 left->op_sibling = right;
5593
1a67a97c
SM		 5594 range->op_next = (OP*)range;
5595 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 5596 flop = newUNOP(OP_FLOP, 0, flip);
11343788 5597 o = newUNOP(OP_NULL, 0, flop);
5983a79d 5598 LINKLIST(flop);
1a67a97c 5599 range->op_next = leftstart;
79072805
LW		 5600
5601 left->op_next = flip;
5602 right->op_next = flop;
5603
1a67a97c
SM		 5604 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5605 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 5606 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 5607 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5608
5609 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5610 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5611
eb796c7f
GG		 5612 /* check barewords before they might be optimized aways */
5613 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5614 no_bareword_allowed(left);
5615 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5616 no_bareword_allowed(right);
5617
11343788 5618 flip->op_next = o;
79072805 5619 if (!flip->op_private || !flop->op_private)
5983a79d 5620 LINKLIST(o); /* blow off optimizer unless constant */
79072805 5621
11343788 5622 return o;
79072805
LW		 5623}
5624
d67eb5f4
Z		 5625/*
5626=for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5627
5628Constructs, checks, and returns an op tree expressing a loop. This is
5629only a loop in the control flow through the op tree; it does not have
5630the heavyweight loop structure that allows exiting the loop by C<last>
5631and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5632top-level op, except that some bits will be set automatically as required.
5633I<expr> supplies the expression controlling loop iteration, and I<block>
5634supplies the body of the loop; they are consumed by this function and
5635become part of the constructed op tree. I<debuggable> is currently
5636unused and should always be 1.
5637
5638=cut
5639*/
5640
79072805 5641OP *
864dbfa3 5642Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 5643{
97aff369 5644 dVAR;
463ee0b2 5645 OP* listop;
11343788 5646 OP* o;
73d840c0 5647 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 5648 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 5649
5650 PERL_UNUSED_ARG(debuggable);
93a17b20 5651
463ee0b2
LW		 5652 if (expr) {
5653 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5654 return block; /* do {} while 0 does once */
114c60ec
BG		 5655 if (expr->op_type == OP_READLINE
5656 || expr->op_type == OP_READDIR
5657 || expr->op_type == OP_GLOB
fb73857a 5658 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 5659 expr = newUNOP(OP_DEFINED, 0,
54b9620d 5660 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 5661 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 5662 const OP * const k1 = ((UNOP*)expr)->op_first;
5663 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 5664 switch (expr->op_type) {
1c846c1f 5665 case OP_NULL:
114c60ec 5666 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
55d729e4 5667 && (k2->op_flags & OPf_STACKED)
1c846c1f 5668 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 5669 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 5670 break;
55d729e4
GS		 5671
5672 case OP_SASSIGN:
06dc7ac6 5673 if (k1 && (k1->op_type == OP_READDIR
55d729e4 5674 || k1->op_type == OP_GLOB
6531c3e6 5675 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 5676 || k1->op_type == OP_EACH
5677 || k1->op_type == OP_AEACH))
55d729e4
GS		 5678 expr = newUNOP(OP_DEFINED, 0, expr);
5679 break;
5680 }
774d564b 5681 }
463ee0b2 5682 }
93a17b20 5683
2fcb4757 5684 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
e1548254
RGS		 5685 * op, in listop. This is wrong. [perl #27024] */
5686 if (!block)
5687 block = newOP(OP_NULL, 0);
2fcb4757 5688 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 5689 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 5690
883ffac3
CS		 5691 if (listop)
5692 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 5693
11343788
MB		 5694 if (once && o != listop)
5695 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 5696
11343788
MB		 5697 if (o == listop)
5698 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 5699
11343788 5700 o->op_flags |= flags;
3ad73efd 5701 o = op_scope(o);
11343788
MB		 5702 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5703 return o;
79072805
LW		 5704}
5705
d67eb5f4 5706/*
94bf0465 5707=for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
d67eb5f4
Z		 5708
5709Constructs, checks, and returns an op tree expressing a C<while> loop.
5710This is a heavyweight loop, with structure that allows exiting the loop
5711by C<last> and suchlike.
5712
5713I<loop> is an optional preconstructed C<enterloop> op to use in the
5714loop; if it is null then a suitable op will be constructed automatically.
5715I<expr> supplies the loop's controlling expression. I<block> supplies the
5716main body of the loop, and I<cont> optionally supplies a C<continue> block
5717that operates as a second half of the body. All of these optree inputs
5718are consumed by this function and become part of the constructed op tree.
5719
5720I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5721op and, shifted up eight bits, the eight bits of C<op_private> for
5722the C<leaveloop> op, except that (in both cases) some bits will be set
5723automatically. I<debuggable> is currently unused and should always be 1.
94bf0465 5724I<has_my> can be supplied as true to force the
d67eb5f4
Z		 5725loop body to be enclosed in its own scope.
5726
5727=cut
5728*/
5729
79072805 5730OP *
94bf0465
Z		 5731Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5732 OP *expr, OP *block, OP *cont, I32 has_my)
79072805 5733{
27da23d5 5734 dVAR;
79072805 5735 OP *redo;
c445ea15 5736 OP *next = NULL;
79072805 5737 OP *listop;
11343788 5738 OP *o;
1ba6ee2b 5739 U8 loopflags = 0;
46c461b5
AL		 5740
5741 PERL_UNUSED_ARG(debuggable);
79072805 5742
2d03de9c 5743 if (expr) {
114c60ec
BG		 5744 if (expr->op_type == OP_READLINE
5745 || expr->op_type == OP_READDIR
5746 || expr->op_type == OP_GLOB
2d03de9c
AL		 5747 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5748 expr = newUNOP(OP_DEFINED, 0,
5749 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5750 } else if (expr->op_flags & OPf_KIDS) {
5751 const OP * const k1 = ((UNOP*)expr)->op_first;
5752 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5753 switch (expr->op_type) {
5754 case OP_NULL:
114c60ec 5755 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
2d03de9c
AL		 5756 && (k2->op_flags & OPf_STACKED)
5757 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5758 expr = newUNOP(OP_DEFINED, 0, expr);
5759 break;
55d729e4 5760
2d03de9c 5761 case OP_SASSIGN:
72c8de1a 5762 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 5763 || k1->op_type == OP_GLOB
5764 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
459b64da
HY		 5765 || k1->op_type == OP_EACH
5766 || k1->op_type == OP_AEACH))
2d03de9c
AL		 5767 expr = newUNOP(OP_DEFINED, 0, expr);
5768 break;
5769 }
55d729e4 5770 }
748a9306 5771 }
79072805
LW		 5772
5773 if (!block)
5774 block = newOP(OP_NULL, 0);
a034e688 5775 else if (cont || has_my) {
3ad73efd 5776 block = op_scope(block);
87246558 5777 }
79072805 5778
1ba6ee2b 5779 if (cont) {
79072805 5780 next = LINKLIST(cont);
1ba6ee2b 5781 }
fb73857a 5782 if (expr) {
551405c4 5783 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 5784 if (!next)
5785 next = unstack;
2fcb4757 5786 cont = op_append_elem(OP_LINESEQ, cont, unstack);
fb73857a 5787 }
79072805 5788
ce3e5c45 5789 assert(block);
2fcb4757 5790 listop = op_append_list(OP_LINESEQ, block, cont);
ce3e5c45 5791 assert(listop);
79072805
LW		 5792 redo = LINKLIST(listop);
5793
5794 if (expr) {
883ffac3
CS		 5795 scalar(listop);
5796 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 5797 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 5798 op_free(expr); /* oops, it's a while (0) */
463ee0b2 5799 op_free((OP*)loop);
5f66b61c 5800 return NULL; /* listop already freed by new_logop */
463ee0b2 5801 }
883ffac3 5802 if (listop)
497b47a8 5803 ((LISTOP*)listop)->op_last->op_next =
883ffac3 5804 (o == listop ? redo : LINKLIST(o));
79072805
LW		 5805 }
5806 else
11343788 5807 o = listop;
79072805
LW		 5808
5809 if (!loop) {
b7dc083c 5810 NewOp(1101,loop,1,LOOP);
79072805 5811 loop->op_type = OP_ENTERLOOP;
22c35a8c 5812 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 5813 loop->op_private = 0;
5814 loop->op_next = (OP*)loop;
5815 }
5816
11343788 5817 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 5818
5819 loop->op_redoop = redo;
11343788 5820 loop->op_lastop = o;
1ba6ee2b 5821 o->op_private |= loopflags;
79072805
LW		 5822
5823 if (next)
5824 loop->op_nextop = next;
5825 else
11343788 5826 loop->op_nextop = o;
79072805 5827
11343788
MB		 5828 o->op_flags |= flags;
5829 o->op_private |= (flags >> 8);
5830 return o;
79072805
LW		 5831}
5832
d67eb5f4 5833/*
94bf0465 5834=for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
d67eb5f4
Z		 5835
5836Constructs, checks, and returns an op tree expressing a C<foreach>
5837loop (iteration through a list of values). This is a heavyweight loop,
5838with structure that allows exiting the loop by C<last> and suchlike.
5839
5840I<sv> optionally supplies the variable that will be aliased to each
5841item in turn; if null, it defaults to C<$_> (either lexical or global).
5842I<expr> supplies the list of values to iterate over. I<block> supplies
5843the main body of the loop, and I<cont> optionally supplies a C<continue>
5844block that operates as a second half of the body. All of these optree
5845inputs are consumed by this function and become part of the constructed
5846op tree.
5847
5848I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5849op and, shifted up eight bits, the eight bits of C<op_private> for
5850the C<leaveloop> op, except that (in both cases) some bits will be set
94bf0465 5851automatically.
d67eb5f4
Z		 5852
5853=cut
5854*/
5855
79072805 5856OP *
94bf0465 5857Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
79072805 5858{
27da23d5 5859 dVAR;
79072805 5860 LOOP *loop;
fb73857a 5861 OP *wop;
4bbc6d12 5862 PADOFFSET padoff = 0;
4633a7c4 5863 I32 iterflags = 0;
241416b8 5864 I32 iterpflags = 0;
d4c19fe8 5865 OP *madsv = NULL;
79072805 5866
7918f24d
NC		 5867 PERL_ARGS_ASSERT_NEWFOROP;
5868
79072805 5869 if (sv) {
85e6fe83 5870 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 5871 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 5872 sv->op_type = OP_RV2GV;
22c35a8c 5873 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0be9a6bb
RH		 5874
5875 /* The op_type check is needed to prevent a possible segfault
5876 * if the loop variable is undeclared and 'strict vars' is in
5877 * effect. This is illegal but is nonetheless parsed, so we
5878 * may reach this point with an OP_CONST where we're expecting
5879 * an OP_GV.
5880 */
5881 if (cUNOPx(sv)->op_first->op_type == OP_GV
5882 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
0d863452 5883 iterpflags |= OPpITER_DEF;
79072805 5884 }
85e6fe83 5885 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 5886 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 5887 padoff = sv->op_targ;
eb8433b7
NC		 5888 if (PL_madskills)
5889 madsv = sv;
5890 else {
5891 sv->op_targ = 0;
5892 op_free(sv);
5893 }
5f66b61c 5894 sv = NULL;
85e6fe83 5895 }
79072805 5896 else
cea2e8a9 5897 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
f8503592
NC		 5898 if (padoff) {
5899 SV *const namesv = PAD_COMPNAME_SV(padoff);
5900 STRLEN len;
5901 const char *const name = SvPV_const(namesv, len);
5902
5903 if (len == 2 && name[0] == '$' && name[1] == '_')
5904 iterpflags |= OPpITER_DEF;
5905 }
79072805
LW		 5906 }
5907 else {
cc76b5cc 5908 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 5909 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 5910 sv = newGVOP(OP_GV, 0, PL_defgv);
5911 }
5912 else {
5913 padoff = offset;
aabe9514 5914 }
0d863452 5915 iterpflags |= OPpITER_DEF;
79072805 5916 }
5f05dabc 5917 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3ad73efd 5918 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 5919 iterflags |= OPf_STACKED;
5920 }
89ea2908
GA		 5921 else if (expr->op_type == OP_NULL &&
5922 (expr->op_flags & OPf_KIDS) &&
5923 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5924 {
5925 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5926 * set the STACKED flag to indicate that these values are to be
5927 * treated as min/max values by 'pp_iterinit'.
5928 */
d4c19fe8 5929 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 5930 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 5931 OP* const left = range->op_first;
5932 OP* const right = left->op_sibling;
5152d7c7 5933 LISTOP* listop;
89ea2908
GA		 5934
5935 range->op_flags &= ~OPf_KIDS;
5f66b61c 5936 range->op_first = NULL;
89ea2908 5937
5152d7c7 5938 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 5939 listop->op_first->op_next = range->op_next;
5940 left->op_next = range->op_other;
5152d7c7
GS		 5941 right->op_next = (OP*)listop;
5942 listop->op_next = listop->op_first;
89ea2908 5943
eb8433b7
NC		 5944#ifdef PERL_MAD
5945 op_getmad(expr,(OP*)listop,'O');
5946#else
89ea2908 5947 op_free(expr);
eb8433b7 5948#endif
5152d7c7 5949 expr = (OP*)(listop);
93c66552 5950 op_null(expr);
89ea2908
GA		 5951 iterflags |= OPf_STACKED;
5952 }
5953 else {
3ad73efd 5954 expr = op_lvalue(force_list(expr), OP_GREPSTART);
89ea2908
GA		 5955 }
5956
4633a7c4 5957 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
2fcb4757 5958 op_append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 5959 assert(!loop->op_next);
241416b8 5960 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 5961 * for our $x () sets OPpOUR_INTRO */
c5661c80 5962 loop->op_private = (U8)iterpflags;
b7dc083c 5963#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 5964 {
5965 LOOP *tmp;
5966 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 5967 Copy(loop,tmp,1,LISTOP);
bfafaa29 5968 S_op_destroy(aTHX_ (OP*)loop);
155aba94
GS		 5969 loop = tmp;
5970 }
b7dc083c 5971#else
10edeb5d 5972 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
1c846c1f 5973#endif
85e6fe83 5974 loop->op_targ = padoff;
94bf0465 5975 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 5976 if (madsv)
5977 op_getmad(madsv, (OP*)loop, 'v');
eae48c89 5978 return wop;
79072805
LW		 5979}
5980
d67eb5f4
Z		 5981/*
5982=for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5983
5984Constructs, checks, and returns a loop-exiting op (such as C<goto>
5985or C<last>). I<type> is the opcode. I<label> supplies the parameter
5986determining the target of the op; it is consumed by this function and
5987become part of the constructed op tree.
5988
5989=cut
5990*/
5991
8990e307 5992OP*
864dbfa3 5993Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 5994{
97aff369 5995 dVAR;
11343788 5996 OP *o;
2d8e6c8d 5997
7918f24d
NC		 5998 PERL_ARGS_ASSERT_NEWLOOPEX;
5999
e69777c1
GG		 6000 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6001
8990e307 6002 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 6003 /* "last()" means "last" */
6004 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6005 o = newOP(type, OPf_SPECIAL);
6006 else {
ea71c68d 6007 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4ea561bc 6008 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
666ea192 6009 : ""));
cdaebead 6010 }
eb8433b7
NC		 6011#ifdef PERL_MAD
6012 op_getmad(label,o,'L');
6013#else
8990e307 6014 op_free(label);
eb8433b7 6015#endif
8990e307
LW		 6016 }
6017 else {
e3aba57a
RGS		 6018 /* Check whether it's going to be a goto &function */
6019 if (label->op_type == OP_ENTERSUB
6020 && !(label->op_flags & OPf_STACKED))
3ad73efd 6021 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
11343788 6022 o = newUNOP(type, OPf_STACKED, label);
8990e307 6023 }
3280af22 6024 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6025 return o;
8990e307
LW		 6026}
6027
0d863452
RH		 6028/* if the condition is a literal array or hash
6029 (or @{ ... } etc), make a reference to it.
6030 */
6031STATIC OP *
6032S_ref_array_or_hash(pTHX_ OP *cond)
6033{
6034 if (cond
6035 && (cond->op_type == OP_RV2AV
6036 || cond->op_type == OP_PADAV
6037 || cond->op_type == OP_RV2HV
6038 || cond->op_type == OP_PADHV))
6039
3ad73efd 6040 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
0d863452 6041
329a333e
DL		 6042 else if(cond
6043 && (cond->op_type == OP_ASLICE
6044 || cond->op_type == OP_HSLICE)) {
6045
6046 /* anonlist now needs a list from this op, was previously used in
6047 * scalar context */
6048 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6049 cond->op_flags |= OPf_WANT_LIST;
6050
3ad73efd 6051 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
329a333e
DL		 6052 }
6053
0d863452
RH		 6054 else
6055 return cond;
6056}
6057
6058/* These construct the optree fragments representing given()
6059 and when() blocks.
6060
6061 entergiven and enterwhen are LOGOPs; the op_other pointer
6062 points up to the associated leave op. We need this so we
6063 can put it in the context and make break/continue work.
6064 (Also, of course, pp_enterwhen will jump straight to
6065 op_other if the match fails.)
6066 */
6067
4136a0f7 6068STATIC OP *
0d863452
RH		 6069S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6070 I32 enter_opcode, I32 leave_opcode,
6071 PADOFFSET entertarg)
6072{
97aff369 6073 dVAR;
0d863452
RH		 6074 LOGOP *enterop;
6075 OP *o;
6076
7918f24d
NC		 6077 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6078
0d863452 6079 NewOp(1101, enterop, 1, LOGOP);
61a59f30 6080 enterop->op_type = (Optype)enter_opcode;
0d863452
RH		 6081 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6082 enterop->op_flags = (U8) OPf_KIDS;
6083 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6084 enterop->op_private = 0;
6085
6086 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6087
6088 if (cond) {
6089 enterop->op_first = scalar(cond);
6090 cond->op_sibling = block;
6091
6092 o->op_next = LINKLIST(cond);
6093 cond->op_next = (OP *) enterop;
6094 }
6095 else {
6096 /* This is a default {} block */
6097 enterop->op_first = block;
6098 enterop->op_flags |= OPf_SPECIAL;
6099
6100 o->op_next = (OP *) enterop;
6101 }
6102
6103 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6104 entergiven and enterwhen both
6105 use ck_null() */
6106
6107 enterop->op_next = LINKLIST(block);
6108 block->op_next = enterop->op_other = o;
6109
6110 return o;
6111}
6112
6113/* Does this look like a boolean operation? For these purposes
6114 a boolean operation is:
6115 - a subroutine call [*]
6116 - a logical connective
6117 - a comparison operator
6118 - a filetest operator, with the exception of -s -M -A -C
6119 - defined(), exists() or eof()
6120 - /$re/ or $foo =~ /$re/
6121
6122 [*] possibly surprising
6123 */
4136a0f7 6124STATIC bool
ef519e13 6125S_looks_like_bool(pTHX_ const OP *o)
0d863452 6126{
97aff369 6127 dVAR;
7918f24d
NC		 6128
6129 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6130
0d863452
RH		 6131 switch(o->op_type) {
6132 case OP_OR:
f92e1a16 6133 case OP_DOR:
0d863452
RH		 6134 return looks_like_bool(cLOGOPo->op_first);
6135
6136 case OP_AND:
6137 return (
6138 looks_like_bool(cLOGOPo->op_first)
6139 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6140
1e1d4b91 6141 case OP_NULL:
08fe1c44 6142 case OP_SCALAR:
1e1d4b91
JJ		 6143 return (
6144 o->op_flags & OPf_KIDS
6145 && looks_like_bool(cUNOPo->op_first));
6146
0d863452
RH		 6147 case OP_ENTERSUB:
6148
6149 case OP_NOT: case OP_XOR:
0d863452
RH		 6150
6151 case OP_EQ: case OP_NE: case OP_LT:
6152 case OP_GT: case OP_LE: case OP_GE:
6153
6154 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6155 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6156
6157 case OP_SEQ: case OP_SNE: case OP_SLT:
6158 case OP_SGT: case OP_SLE: case OP_SGE:
6159
6160 case OP_SMARTMATCH:
6161
6162 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6163 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6164 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6165 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6166 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6167 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6168 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6169 case OP_FTTEXT: case OP_FTBINARY:
6170
6171 case OP_DEFINED: case OP_EXISTS:
6172 case OP_MATCH: case OP_EOF:
6173
f118ea0d
RGS		 6174 case OP_FLOP:
6175
0d863452
RH		 6176 return TRUE;
6177
6178 case OP_CONST:
6179 /* Detect comparisons that have been optimized away */
6180 if (cSVOPo->op_sv == &PL_sv_yes
6181 || cSVOPo->op_sv == &PL_sv_no)
6182
6183 return TRUE;
6e03d743
RGS		 6184 else
6185 return FALSE;
6e03d743 6186
0d863452
RH		 6187 /* FALL THROUGH */
6188 default:
6189 return FALSE;
6190 }
6191}
6192
d67eb5f4
Z		 6193/*
6194=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6195
6196Constructs, checks, and returns an op tree expressing a C<given> block.
6197I<cond> supplies the expression that will be locally assigned to a lexical
6198variable, and I<block> supplies the body of the C<given> construct; they
6199are consumed by this function and become part of the constructed op tree.
6200I<defsv_off> is the pad offset of the scalar lexical variable that will
6201be affected.
6202
6203=cut
6204*/
6205
0d863452
RH		 6206OP *
6207Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6208{
97aff369 6209 dVAR;
7918f24d 6210 PERL_ARGS_ASSERT_NEWGIVENOP;
0d863452
RH		 6211 return newGIVWHENOP(
6212 ref_array_or_hash(cond),
6213 block,
6214 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6215 defsv_off);
6216}
6217
d67eb5f4
Z		 6218/*
6219=for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6220
6221Constructs, checks, and returns an op tree expressing a C<when> block.
6222I<cond> supplies the test expression, and I<block> supplies the block
6223that will be executed if the test evaluates to true; they are consumed
6224by this function and become part of the constructed op tree. I<cond>
6225will be interpreted DWIMically, often as a comparison against C<$_>,
6226and may be null to generate a C<default> block.
6227
6228=cut
6229*/
6230
0d863452
RH		 6231OP *
6232Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6233{
ef519e13 6234 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 6235 OP *cond_op;
6236
7918f24d
NC		 6237 PERL_ARGS_ASSERT_NEWWHENOP;
6238
0d863452
RH		 6239 if (cond_llb)
6240 cond_op = cond;
6241 else {
6242 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6243 newDEFSVOP(),
6244 scalar(ref_array_or_hash(cond)));
6245 }
6246
c08f093b 6247 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
0d863452
RH		 6248}
6249
3fe9a6f1 6250void
dab1c735
BF		 6251Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6252 const STRLEN len, const U32 flags)
cbf82dd0 6253{
8fa6a409
FC		 6254 const char * const cvp = CvPROTO(cv);
6255 const STRLEN clen = CvPROTOLEN(cv);
6256
dab1c735 6257 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
8fa6a409
FC		 6258
6259 if (((!p != !cvp) /* One has prototype, one has not. */
6260 || (p && (
6261 (flags & SVf_UTF8) == SvUTF8(cv)
6262 ? len != clen || memNE(cvp, p, len)
6263 : flags & SVf_UTF8
6264 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6265 (const U8 *)p, len)
6266 : bytes_cmp_utf8((const U8 *)p, len,
6267 (const U8 *)cvp, clen)
6268 )
6269 )
6270 )
cbf82dd0 6271 && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 6272 SV* const msg = sv_newmortal();
a0714e2c 6273 SV* name = NULL;
3fe9a6f1 6274
6275 if (gv)
bd61b366 6276 gv_efullname3(name = sv_newmortal(), gv, NULL);
6502358f 6277 sv_setpvs(msg, "Prototype mismatch:");
46fc3d4c 6278 if (name)
be2597df 6279 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
3fe9a6f1 6280 if (SvPOK(cv))
8fa6a409
FC		 6281 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6282 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6283 );
ebe643b9 6284 else
396482e1
GA		 6285 sv_catpvs(msg, ": none");
6286 sv_catpvs(msg, " vs ");
46fc3d4c 6287 if (p)
dab1c735 6288 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
46fc3d4c 6289 else
396482e1 6290 sv_catpvs(msg, "none");
be2597df 6291 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 6292 }
6293}
6294
35f1c1c7
SB		 6295static void const_sv_xsub(pTHX_ CV* cv);
6296
beab0874 6297/*
ccfc67b7
JH		 6298
6299=head1 Optree Manipulation Functions
6300
beab0874
JT		 6301=for apidoc cv_const_sv
6302
6303If C<cv> is a constant sub eligible for inlining. returns the constant
6304value returned by the sub. Otherwise, returns NULL.
6305
6306Constant subs can be created with C<newCONSTSUB> or as described in
6307L<perlsub/"Constant Functions">.
6308
6309=cut
6310*/
760ac839 6311SV *
d45f5b30 6312Perl_cv_const_sv(pTHX_ const CV *const cv)
760ac839 6313{
96a5add6 6314 PERL_UNUSED_CONTEXT;
5069cc75
NC		 6315 if (!cv)
6316 return NULL;
6317 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6318 return NULL;
ad64d0ec 6319 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
fe5e78ed 6320}
760ac839 6321
b5c19bd7
DM		 6322/* op_const_sv: examine an optree to determine whether it's in-lineable.
6323 * Can be called in 3 ways:
6324 *
6325 * !cv
6326 * look for a single OP_CONST with attached value: return the value
6327 *
6328 * cv && CvCLONE(cv) && !CvCONST(cv)
6329 *
6330 * examine the clone prototype, and if contains only a single
6331 * OP_CONST referencing a pad const, or a single PADSV referencing
6332 * an outer lexical, return a non-zero value to indicate the CV is
6333 * a candidate for "constizing" at clone time
6334 *
6335 * cv && CvCONST(cv)
6336 *
6337 * We have just cloned an anon prototype that was marked as a const
486ec47a 6338 * candidate. Try to grab the current value, and in the case of
b5c19bd7
DM		 6339 * PADSV, ignore it if it has multiple references. Return the value.
6340 */
6341
fe5e78ed 6342SV *
6867be6d 6343Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 6344{
97aff369 6345 dVAR;
a0714e2c 6346 SV *sv = NULL;
fe5e78ed 6347
c631f32b
GG		 6348 if (PL_madskills)
6349 return NULL;
6350
0f79a09d 6351 if (!o)
a0714e2c 6352 return NULL;
1c846c1f
NIS		 6353
6354 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 6355 o = cLISTOPo->op_first->op_sibling;
6356
6357 for (; o; o = o->op_next) {
890ce7af 6358 const OPCODE type = o->op_type;
fe5e78ed 6359
1c846c1f 6360 if (sv && o->op_next == o)
fe5e78ed 6361 return sv;
e576b457 6362 if (o->op_next != o) {
dbe92b04
FC		 6363 if (type == OP_NEXTSTATE
6364 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6365 || type == OP_PUSHMARK)
e576b457
JT		 6366 continue;
6367 if (type == OP_DBSTATE)
6368 continue;
6369 }
54310121 6370 if (type == OP_LEAVESUB || type == OP_RETURN)
6371 break;
6372 if (sv)
a0714e2c 6373 return NULL;
7766f137 6374 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 6375 sv = cSVOPo->op_sv;
b5c19bd7 6376 else if (cv && type == OP_CONST) {
dd2155a4 6377 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 6378 if (!sv)
a0714e2c 6379 return NULL;
b5c19bd7
DM		 6380 }
6381 else if (cv && type == OP_PADSV) {
6382 if (CvCONST(cv)) { /* newly cloned anon */
6383 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6384 /* the candidate should have 1 ref from this pad and 1 ref
6385 * from the parent */
6386 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 6387 return NULL;
beab0874 6388 sv = newSVsv(sv);
b5c19bd7
DM		 6389 SvREADONLY_on(sv);
6390 return sv;
6391 }
6392 else {
6393 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6394 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 6395 }
760ac839 6396 }
b5c19bd7 6397 else {
a0714e2c 6398 return NULL;
b5c19bd7 6399 }
760ac839
LW		 6400 }
6401 return sv;
6402}
6403
eb8433b7
NC		 6404#ifdef PERL_MAD
6405OP *
6406#else
09bef843 6407void
eb8433b7 6408#endif
09bef843
SB		 6409Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6410{
99129197
NC		 6411#if 0
6412 /* This would be the return value, but the return cannot be reached. */
eb8433b7
NC		 6413 OP* pegop = newOP(OP_NULL, 0);
6414#endif
6415
46c461b5
AL		 6416 PERL_UNUSED_ARG(floor);
6417
09bef843
SB		 6418 if (o)
6419 SAVEFREEOP(o);
6420 if (proto)
6421 SAVEFREEOP(proto);
6422 if (attrs)
6423 SAVEFREEOP(attrs);
6424 if (block)
6425 SAVEFREEOP(block);
6426 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
eb8433b7 6427#ifdef PERL_MAD
99129197 6428 NORETURN_FUNCTION_END;
eb8433b7 6429#endif
09bef843
SB		 6430}
6431
748a9306 6432CV *
09bef843
SB		 6433Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6434{
27da23d5 6435 dVAR;
83ee9e09 6436 GV *gv;
5c144d81 6437 const char *ps;
52a9a866 6438 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
e0260a5b 6439 U32 ps_utf8 = 0;
c445ea15 6440 register CV *cv = NULL;
beab0874 6441 SV *const_sv;
b48b272a
NC		 6442 /* If the subroutine has no body, no attributes, and no builtin attributes
6443 then it's just a sub declaration, and we may be able to get away with
6444 storing with a placeholder scalar in the symbol table, rather than a
6445 full GV and CV. If anything is present then it will take a full CV to
6446 store it. */
6447 const I32 gv_fetch_flags
eb8433b7
NC		 6448 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6449 || PL_madskills)
b48b272a 6450 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4ea561bc 6451 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
ed4a8a9b 6452 bool has_name;
3453414d 6453 bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
8e742a20
MHM		 6454
6455 if (proto) {
6456 assert(proto->op_type == OP_CONST);
4ea561bc 6457 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
e0260a5b 6458 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8e742a20
MHM		 6459 }
6460 else
bd61b366 6461 ps = NULL;
8e742a20 6462
ed4a8a9b
NC		 6463 if (name) {
6464 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6465 has_name = TRUE;
6466 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 6467 SV * const sv = sv_newmortal();
c99da370
JH		 6468 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6469 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 6470 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
ed4a8a9b
NC		 6471 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6472 has_name = TRUE;
c1754fce
NC		 6473 } else if (PL_curstash) {
6474 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 6475 has_name = FALSE;
c1754fce
NC		 6476 } else {
6477 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 6478 has_name = FALSE;
c1754fce 6479 }
83ee9e09 6480
eb8433b7
NC		 6481 if (!PL_madskills) {
6482 if (o)
6483 SAVEFREEOP(o);
6484 if (proto)
6485 SAVEFREEOP(proto);
6486 if (attrs)
6487 SAVEFREEOP(attrs);
6488 }
3fe9a6f1 6489
09bef843 6490 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 6491 maximum a prototype before. */
6492 if (SvTYPE(gv) > SVt_NULL) {
ad64d0ec 6493 if (!SvPOK((const SV *)gv)
9b387841 6494 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
f248d071 6495 {
9b387841 6496 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 6497 }
dab1c735 6498 cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
55d729e4 6499 }
e0260a5b 6500 if (ps) {
ad64d0ec 6501 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
e0260a5b
BF		 6502 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
6503 }
55d729e4 6504 else
ad64d0ec 6505 sv_setiv(MUTABLE_SV(gv), -1);
e1a479c5 6506
3280af22
NIS		 6507 SvREFCNT_dec(PL_compcv);
6508 cv = PL_compcv = NULL;
beab0874 6509 goto done;
55d729e4
GS		 6510 }
6511
601f1833 6512 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 6513
eb8433b7
NC		 6514 if (!block || !ps || *ps || attrs
6515 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6516#ifdef PERL_MAD
6517 || block->op_type == OP_NULL
6518#endif
6519 )
a0714e2c 6520 const_sv = NULL;
beab0874 6521 else
601f1833 6522 const_sv = op_const_sv(block, NULL);
beab0874
JT		 6523
6524 if (cv) {
6867be6d 6525 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 6526
60ed1d8c
GS		 6527 /* if the subroutine doesn't exist and wasn't pre-declared
6528 * with a prototype, assume it will be AUTOLOADed,
6529 * skipping the prototype check
6530 */
6531 if (exists || SvPOK(cv))
dab1c735 6532 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
68dc0745 6533 /* already defined (or promised)? */
60ed1d8c 6534 if (exists || GvASSUMECV(gv)) {
eb8433b7
NC		 6535 if ((!block
6536#ifdef PERL_MAD
6537 || block->op_type == OP_NULL
6538#endif
fff96ff7 6539 )) {
d3cea301
SB		 6540 if (CvFLAGS(PL_compcv)) {
6541 /* might have had built-in attrs applied */
4dbb339a
FC		 6542 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6543 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6544 && ckWARN(WARN_MISC))
885ef6f5 6545 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
4dbb339a
FC		 6546 CvFLAGS(cv) |=
6547 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6548 & ~(CVf_LVALUE * pureperl));
d3cea301 6549 }
fff96ff7 6550 if (attrs) goto attrs;
aa689395 6551 /* just a "sub foo;" when &foo is already defined */
3280af22 6552 SAVEFREESV(PL_compcv);
aa689395 6553 goto done;
6554 }
eb8433b7
NC		 6555 if (block
6556#ifdef PERL_MAD
6557 && block->op_type != OP_NULL
6558#endif
6559 ) {
beab0874
JT		 6560 if (ckWARN(WARN_REDEFINE)
6561 || (CvCONST(cv)
6562 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6563 {
6867be6d 6564 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 6565 if (PL_parser && PL_parser->copline != NOLINE)
6566 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 6567 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
34ee6772
BF		 6568 CvCONST(cv) ? "Constant subroutine %"SVf" redefined"
6569 : "Subroutine %"SVf" redefined",
6570 SVfARG(cSVOPo->op_sv));
beab0874
JT		 6571 CopLINE_set(PL_curcop, oldline);
6572 }
eb8433b7
NC		 6573#ifdef PERL_MAD
6574 if (!PL_minus_c) /* keep old one around for madskills */
6575#endif
6576 {
6577 /* (PL_madskills unset in used file.) */
6578 SvREFCNT_dec(cv);
6579 }
601f1833 6580 cv = NULL;
79072805 6581 }
79072805
LW		 6582 }
6583 }
beab0874 6584 if (const_sv) {
03d9f026 6585 HV *stash;
f84c484e 6586 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 6587 if (cv) {
0768512c 6588 assert(!CvROOT(cv) && !CvCONST(cv));
ad64d0ec 6589 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
beab0874
JT		 6590 CvXSUBANY(cv).any_ptr = const_sv;
6591 CvXSUB(cv) = const_sv_xsub;
6592 CvCONST_on(cv);
d04ba589 6593 CvISXSUB_on(cv);
beab0874
JT		 6594 }
6595 else {
c43ae56f 6596 GvCV_set(gv, NULL);
3453414d 6597 cv = newCONSTSUB_flags(NULL, name, name_is_utf8 ? SVf_UTF8 : 0, const_sv);
beab0874 6598 }
03d9f026 6599 stash =
e1a479c5
BB		 6600 (CvGV(cv) && GvSTASH(CvGV(cv)))
6601 ? GvSTASH(CvGV(cv))
6602 : CvSTASH(cv)
6603 ? CvSTASH(cv)
03d9f026
FC		 6604 : PL_curstash;
6605 if (HvENAME_HEK(stash))
6606 mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
eb8433b7
NC		 6607 if (PL_madskills)
6608 goto install_block;
beab0874
JT		 6609 op_free(block);
6610 SvREFCNT_dec(PL_compcv);
6611 PL_compcv = NULL;
beab0874
JT		 6612 goto done;
6613 }
09330df8
Z		 6614 if (cv) { /* must reuse cv if autoloaded */
6615 /* transfer PL_compcv to cv */
6616 if (block
eb8433b7 6617#ifdef PERL_MAD
09330df8 6618 && block->op_type != OP_NULL
eb8433b7 6619#endif
09330df8 6620 ) {
eac910c8 6621 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
437388a9
NC		 6622 AV *const temp_av = CvPADLIST(cv);
6623 CV *const temp_cv = CvOUTSIDE(cv);
6624
6625 assert(!CvWEAKOUTSIDE(cv));
6626 assert(!CvCVGV_RC(cv));
6627 assert(CvGV(cv) == gv);
6628
6629 SvPOK_off(cv);
eac910c8 6630 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
09330df8
Z		 6631 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6632 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
09330df8 6633 CvPADLIST(cv) = CvPADLIST(PL_compcv);
437388a9
NC		 6634 CvOUTSIDE(PL_compcv) = temp_cv;
6635 CvPADLIST(PL_compcv) = temp_av;
6636
bad4ae38 6637 if (CvFILE(cv) && CvDYNFILE(cv)) {
437388a9
NC		 6638 Safefree(CvFILE(cv));
6639 }
437388a9
NC		 6640 CvFILE_set_from_cop(cv, PL_curcop);
6641 CvSTASH_set(cv, PL_curstash);
6642
09330df8
Z		 6643 /* inner references to PL_compcv must be fixed up ... */
6644 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6645 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6646 ++PL_sub_generation;
09bef843
SB		 6647 }
6648 else {
09330df8
Z		 6649 /* Might have had built-in attributes applied -- propagate them. */
6650 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
09bef843 6651 }
282f25c9 6652 /* ... before we throw it away */
3280af22 6653 SvREFCNT_dec(PL_compcv);
b5c19bd7 6654 PL_compcv = cv;
a0d0e21e
LW		 6655 }
6656 else {
3280af22 6657 cv = PL_compcv;
44a8e56a 6658 if (name) {
c43ae56f 6659 GvCV_set(gv, cv);
eb8433b7
NC		 6660 if (PL_madskills) {
6661 if (strEQ(name, "import")) {
ad64d0ec 6662 PL_formfeed = MUTABLE_SV(cv);
06f07c2f 6663 /* diag_listed_as: SKIPME */
fea10cf6 6664 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
eb8433b7
NC		 6665 }
6666 }
44a8e56a 6667 GvCVGEN(gv) = 0;
03d9f026
FC		 6668 if (HvENAME_HEK(GvSTASH(gv)))
6669 /* sub Foo::bar { (shift)+1 } */
6670 mro_method_changed_in(GvSTASH(gv));
44a8e56a 6671 }
a0d0e21e 6672 }
09330df8 6673 if (!CvGV(cv)) {
b3f91e91 6674 CvGV_set(cv, gv);
09330df8 6675 CvFILE_set_from_cop(cv, PL_curcop);
c68d9564 6676 CvSTASH_set(cv, PL_curstash);
09330df8 6677 }
8990e307 6678
e0260a5b 6679 if (ps) {
ad64d0ec 6680 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
e0260a5b
BF		 6681 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
6682 }
4633a7c4 6683
13765c85 6684 if (PL_parser && PL_parser->error_count) {
c07a80fd 6685 op_free(block);
5f66b61c 6686 block = NULL;
68dc0745 6687 if (name) {
6867be6d 6688 const char *s = strrchr(name, ':');
68dc0745 6689 s = s ? s+1 : name;
6d4c2119 6690 if (strEQ(s, "BEGIN")) {
e1ec3a88 6691 const char not_safe[] =
6d4c2119 6692 "BEGIN not safe after errors--compilation aborted";
faef0170 6693 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 6694 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 6695 else {
6696 /* force display of errors found but not reported */
38a03e6e 6697 sv_catpv(ERRSV, not_safe);
be2597df 6698 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6d4c2119
CS		 6699 }
6700 }
68dc0745 6701 }
c07a80fd 6702 }
eb8433b7 6703 install_block:
beab0874 6704 if (!block)
fb834abd 6705 goto attrs;
a0d0e21e 6706
aac018bb
NC		 6707 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6708 the debugger could be able to set a breakpoint in, so signal to
6709 pp_entereval that it should not throw away any saved lines at scope
6710 exit. */
6711
fd06b02c 6712 PL_breakable_sub_gen++;
69b22cd1
FC		 6713 /* This makes sub {}; work as expected. */
6714 if (block->op_type == OP_STUB) {
1496a290 6715 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 6716#ifdef PERL_MAD
6717 op_getmad(block,newblock,'B');
6718#else
09c2fd24 6719 op_free(block);
eb8433b7
NC		 6720#endif
6721 block = newblock;
7766f137 6722 }
69b22cd1
FC		 6723 else block->op_attached = 1;
6724 CvROOT(cv) = CvLVALUE(cv)
6725 ? newUNOP(OP_LEAVESUBLV, 0,
6726 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6727 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7766f137
GS		 6728 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6729 OpREFCNT_set(CvROOT(cv), 1);
6730 CvSTART(cv) = LINKLIST(CvROOT(cv));
6731 CvROOT(cv)->op_next = 0;
a2efc822 6732 CALL_PEEP(CvSTART(cv));
d164302a 6733 finalize_optree(CvROOT(cv));
7766f137
GS		 6734
6735 /* now that optimizer has done its work, adjust pad values */
54310121 6736
dd2155a4
DM		 6737 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6738
6739 if (CvCLONE(cv)) {
beab0874
JT		 6740 assert(!CvCONST(cv));
6741 if (ps && !*ps && op_const_sv(block, cv))
6742 CvCONST_on(cv);
a0d0e21e 6743 }
79072805 6744
fb834abd
FC		 6745 attrs:
6746 if (attrs) {
6747 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6748 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6749 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6750 }
6751
6752 if (block && has_name) {
3280af22 6753 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
c4420975 6754 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 6755 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6756 GV_ADDMULTI, SVt_PVHV);
44a8e56a 6757 HV *hv;
b081dd7e
NC		 6758 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6759 CopFILE(PL_curcop),
6760 (long)PL_subline,
6761 (long)CopLINE(PL_curcop));
bd61b366 6762 gv_efullname3(tmpstr, gv, NULL);
04fe65b0 6763 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
c60dbbc3 6764 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
44a8e56a 6765 hv = GvHVn(db_postponed);
c60dbbc3 6766 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
551405c4
AL		 6767 CV * const pcv = GvCV(db_postponed);
6768 if (pcv) {
6769 dSP;
6770 PUSHMARK(SP);
6771 XPUSHs(tmpstr);
6772 PUTBACK;
ad64d0ec 6773 call_sv(MUTABLE_SV(pcv), G_DISCARD);
551405c4 6774 }
44a8e56a 6775 }
6776 }
79072805 6777
13765c85 6778 if (name && ! (PL_parser && PL_parser->error_count))
0cd10f52 6779 process_special_blocks(name, gv, cv);
33fb7a6e 6780 }
ed094faf 6781
33fb7a6e 6782 done:
53a7735b
DM		 6783 if (PL_parser)
6784 PL_parser->copline = NOLINE;
33fb7a6e
NC		 6785 LEAVE_SCOPE(floor);
6786 return cv;
6787}
ed094faf 6788
33fb7a6e
NC		 6789STATIC void
6790S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6791 CV *const cv)
6792{
6793 const char *const colon = strrchr(fullname,':');
6794 const char *const name = colon ? colon + 1 : fullname;
6795
7918f24d
NC		 6796 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6797
33fb7a6e 6798 if (*name == 'B') {
6952d67e 6799 if (strEQ(name, "BEGIN")) {
6867be6d 6800 const I32 oldscope = PL_scopestack_ix;
28757baa 6801 ENTER;
57843af0
GS		 6802 SAVECOPFILE(&PL_compiling);
6803 SAVECOPLINE(&PL_compiling);
28757baa 6804
a58fb6f9 6805 DEBUG_x( dump_sub(gv) );
ad64d0ec 6806 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
c43ae56f 6807 GvCV_set(gv,0); /* cv has been hijacked */
3280af22 6808 call_list(oldscope, PL_beginav);
a6006777 6809
3280af22 6810 PL_curcop = &PL_compiling;
623e6609 6811 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 6812 LEAVE;
6813 }
33fb7a6e
NC		 6814 else
6815 return;
6816 } else {
6817 if (*name == 'E') {
6818 if strEQ(name, "END") {
a58fb6f9 6819 DEBUG_x( dump_sub(gv) );
ad64d0ec 6820 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
33fb7a6e
NC		 6821 } else
6822 return;
6823 } else if (*name == 'U') {
6824 if (strEQ(name, "UNITCHECK")) {
6825 /* It's never too late to run a unitcheck block */
ad64d0ec 6826 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
33fb7a6e
NC		 6827 }
6828 else
6829 return;
6830 } else if (*name == 'C') {
6831 if (strEQ(name, "CHECK")) {
a2a5de95
NC		 6832 if (PL_main_start)
6833 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6834 "Too late to run CHECK block");
ad64d0ec 6835 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
33fb7a6e
NC		 6836 }
6837 else
6838 return;
6839 } else if (*name == 'I') {
6840 if (strEQ(name, "INIT")) {
a2a5de95
NC		 6841 if (PL_main_start)
6842 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6843 "Too late to run INIT block");
ad64d0ec 6844 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
33fb7a6e
NC		 6845 }
6846 else
6847 return;
6848 } else
6849 return;
a58fb6f9 6850 DEBUG_x( dump_sub(gv) );
c43ae56f 6851 GvCV_set(gv,0); /* cv has been hijacked */
79072805 6852 }
79072805
LW		 6853}
6854
954c1994
GS		 6855/*
6856=for apidoc newCONSTSUB
6857
3453414d
BF		 6858See L</newCONSTSUB_flags>.
6859
6860=cut
6861*/
6862
6863CV *
6864Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6865{
6866 return newCONSTSUB_flags(stash, name, 0, sv);
6867}
6868
6869/*
6870=for apidoc newCONSTSUB_flags
6871
954c1994
GS		 6872Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6873eligible for inlining at compile-time.
6874
3453414d
BF		 6875Currently, the only useful value for C<flags> is SVf_UTF8.
6876
99ab892b
NC		 6877Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6878which won't be called if used as a destructor, but will suppress the overhead
6879of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6880compile time.)
6881
954c1994
GS		 6882=cut
6883*/
6884
beab0874 6885CV *
3453414d 6886Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, U32 flags, SV *sv)
5476c433 6887{
27da23d5 6888 dVAR;
beab0874 6889 CV* cv;
cbf82dd0 6890#ifdef USE_ITHREADS
54d012c6 6891 const char *const file = CopFILE(PL_curcop);
cbf82dd0
NC		 6892#else
6893 SV *const temp_sv = CopFILESV(PL_curcop);
def18e4c 6894 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
cbf82dd0 6895#endif
5476c433 6896
11faa288 6897 ENTER;
11faa288 6898
401667e9
DM		 6899 if (IN_PERL_RUNTIME) {
6900 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6901 * an op shared between threads. Use a non-shared COP for our
6902 * dirty work */
6903 SAVEVPTR(PL_curcop);
6904 PL_curcop = &PL_compiling;
6905 }
f4dd75d9 6906 SAVECOPLINE(PL_curcop);
53a7735b 6907 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 6908
6909 SAVEHINTS();
3280af22 6910 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 6911
6912 if (stash) {
03d9f026 6913 SAVEGENERICSV(PL_curstash);
11faa288 6914 SAVECOPSTASH(PL_curcop);
03d9f026 6915 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
05ec9bb3 6916 CopSTASH_set(PL_curcop,stash);
11faa288 6917 }
5476c433 6918
bad4ae38 6919 /* file becomes the CvFILE. For an XS, it's usually static storage,
cbf82dd0
NC		 6920 and so doesn't get free()d. (It's expected to be from the C pre-
6921 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee 6922 and we need it to get freed. */
54d012c6 6923 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
3453414d 6924 XS_DYNAMIC_FILENAME | flags);
beab0874
JT		 6925 CvXSUBANY(cv).any_ptr = sv;
6926 CvCONST_on(cv);
5476c433 6927
65e66c80 6928#ifdef USE_ITHREADS
02f28d44
MHM		 6929 if (stash)
6930 CopSTASH_free(PL_curcop);
65e66c80 6931#endif
11faa288 6932 LEAVE;
beab0874
JT		 6933
6934 return cv;
5476c433
JD		 6935}
6936
77004dee
NC		 6937CV *
6938Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6939 const char *const filename, const char *const proto,
6940 U32 flags)
6941{
3453414d 6942 CV *cv;
77004dee 6943
7918f24d
NC		 6944 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6945
3453414d
BF		 6946 {
6947 GV * const gv = gv_fetchpv(name ? name :
6948 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6949 GV_ADDMULTI | flags, SVt_PVCV);
6950
6951 if (!subaddr)
6952 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6953
6954 if ((cv = (name ? GvCV(gv) : NULL))) {
6955 if (GvCVGEN(gv)) {
6956 /* just a cached method */
6957 SvREFCNT_dec(cv);
6958 cv = NULL;
6959 }
6960 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6961 /* already defined (or promised) */
3453414d
BF		 6962 if (ckWARN(WARN_REDEFINE)) {
6963 GV * const gvcv = CvGV(cv);
6964 if (gvcv) {
6965 HV * const stash = GvSTASH(gvcv);
6966 if (stash) {
6967 const char *redefined_name = HvNAME_get(stash);
218fa151
FC		 6968 if ( redefined_name &&
6969 strEQ(redefined_name,"autouse") ) {
3453414d
BF		 6970 const line_t oldline = CopLINE(PL_curcop);
6971 if (PL_parser && PL_parser->copline != NOLINE)
6972 CopLINE_set(PL_curcop, PL_parser->copline);
6973 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6974 CvCONST(cv) ? "Constant subroutine %s redefined"
6975 : "Subroutine %s redefined"
6976 ,name);
6977 CopLINE_set(PL_curcop, oldline);
6978 }
6979 }
6980 }
6981 }
6982 SvREFCNT_dec(cv);
6983 cv = NULL;
6984 }
6985 }
6986
6987 if (cv) /* must reuse cv if autoloaded */
6988 cv_undef(cv);
6989 else {
6990 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6991 if (name) {
6992 GvCV_set(gv,cv);
6993 GvCVGEN(gv) = 0;
03d9f026
FC		 6994 if (HvENAME_HEK(GvSTASH(gv)))
6995 mro_method_changed_in(GvSTASH(gv)); /* newXS */
3453414d
BF		 6996 }
6997 }
6998 if (!name)
6999 CvANON_on(cv);
7000 CvGV_set(cv, gv);
7001 (void)gv_fetchfile(filename);
7002 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7003 an external constant string */
7004 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7005 CvISXSUB_on(cv);
7006 CvXSUB(cv) = subaddr;
7007
7008 if (name)
7009 process_special_blocks(name, gv, cv);
7010 }
7011
77004dee 7012 if (flags & XS_DYNAMIC_FILENAME) {
bad4ae38
FC		 7013 CvFILE(cv) = savepv(filename);
7014 CvDYNFILE_on(cv);
77004dee 7015 }
bad4ae38 7016 sv_setpv(MUTABLE_SV(cv), proto);
77004dee
NC		 7017 return cv;
7018}
7019
954c1994
GS		 7020/*
7021=for apidoc U||newXS
7022
77004dee
NC		 7023Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7024static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 7025
7026=cut
7027*/
7028
57d3b86d 7029CV *
bfed75c6 7030Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 7031{
7918f24d 7032 PERL_ARGS_ASSERT_NEWXS;
3453414d 7033 return newXS_flags(name, subaddr, filename, NULL, 0);
79072805
LW		 7034}
7035
eb8433b7
NC		 7036#ifdef PERL_MAD
7037OP *
7038#else
79072805 7039void
eb8433b7 7040#endif
864dbfa3 7041Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 7042{
97aff369 7043 dVAR;
79072805 7044 register CV *cv;
eb8433b7
NC		 7045#ifdef PERL_MAD
7046 OP* pegop = newOP(OP_NULL, 0);
7047#endif
79072805 7048
0bd48802 7049 GV * const gv = o
f776e3cd 7050 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 7051 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 7052
a5f75d66 7053 GvMULTI_on(gv);
155aba94 7054 if ((cv = GvFORM(gv))) {
599cee73 7055 if (ckWARN(WARN_REDEFINE)) {
6867be6d 7056 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 7057 if (PL_parser && PL_parser->copline != NOLINE)
7058 CopLINE_set(PL_curcop, PL_parser->copline);
ee6d2783
NC		 7059 if (o) {
7060 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7061 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7062 } else {
7063 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7064 "Format STDOUT redefined");
7065 }
57843af0 7066 CopLINE_set(PL_curcop, oldline);
79072805 7067 }
8990e307 7068 SvREFCNT_dec(cv);
79072805 7069 }
3280af22 7070 cv = PL_compcv;
79072805 7071 GvFORM(gv) = cv;
b3f91e91 7072 CvGV_set(cv, gv);
a636914a 7073 CvFILE_set_from_cop(cv, PL_curcop);
79072805 7074
a0d0e21e 7075
dd2155a4 7076 pad_tidy(padtidy_FORMAT);
79072805 7077 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 7078 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7079 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 7080 CvSTART(cv) = LINKLIST(CvROOT(cv));
7081 CvROOT(cv)->op_next = 0;
a2efc822 7082 CALL_PEEP(CvSTART(cv));
aee4f072 7083 finalize_optree(CvROOT(cv));
eb8433b7
NC		 7084#ifdef PERL_MAD
7085 op_getmad(o,pegop,'n');
7086 op_getmad_weak(block, pegop, 'b');
7087#else
11343788 7088 op_free(o);
eb8433b7 7089#endif
53a7735b
DM		 7090 if (PL_parser)
7091 PL_parser->copline = NOLINE;
8990e307 7092 LEAVE_SCOPE(floor);
eb8433b7
NC		 7093#ifdef PERL_MAD
7094 return pegop;
7095#endif
79072805
LW		 7096}
7097
7098OP *
864dbfa3 7099Perl_newANONLIST(pTHX_ OP *o)
79072805 7100{
78c72037 7101 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 7102}
7103
7104OP *
864dbfa3 7105Perl_newANONHASH(pTHX_ OP *o)
79072805 7106{
78c72037 7107 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 7108}
7109
7110OP *
864dbfa3 7111Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 7112{
5f66b61c 7113 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 7114}
7115
7116OP *
7117Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7118{
a0d0e21e 7119 return newUNOP(OP_REFGEN, 0,
09bef843 7120 newSVOP(OP_ANONCODE, 0,
ad64d0ec 7121 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
79072805
LW		 7122}
7123
7124OP *
864dbfa3 7125Perl_oopsAV(pTHX_ OP *o)
79072805 7126{
27da23d5 7127 dVAR;
7918f24d
NC		 7128
7129 PERL_ARGS_ASSERT_OOPSAV;
7130
ed6116ce
LW		 7131 switch (o->op_type) {
7132 case OP_PADSV:
7133 o->op_type = OP_PADAV;
22c35a8c 7134 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 7135 return ref(o, OP_RV2AV);
b2ffa427 7136
ed6116ce 7137 case OP_RV2SV:
79072805 7138 o->op_type = OP_RV2AV;
22c35a8c 7139 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 7140 ref(o, OP_RV2AV);
ed6116ce
LW		 7141 break;
7142
7143 default:
9b387841 7144 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 7145 break;
7146 }
79072805
LW		 7147 return o;
7148}
7149
7150OP *
864dbfa3 7151Perl_oopsHV(pTHX_ OP *o)
79072805 7152{
27da23d5 7153 dVAR;
7918f24d
NC		 7154
7155 PERL_ARGS_ASSERT_OOPSHV;
7156
ed6116ce
LW		 7157 switch (o->op_type) {
7158 case OP_PADSV:
7159 case OP_PADAV:
7160 o->op_type = OP_PADHV;
22c35a8c 7161 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 7162 return ref(o, OP_RV2HV);
ed6116ce
LW		 7163
7164 case OP_RV2SV:
7165 case OP_RV2AV:
79072805 7166 o->op_type = OP_RV2HV;
22c35a8c 7167 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 7168 ref(o, OP_RV2HV);
ed6116ce
LW		 7169 break;
7170
7171 default:
9b387841 7172 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 7173 break;
7174 }
79072805
LW		 7175 return o;
7176}
7177
7178OP *
864dbfa3 7179Perl_newAVREF(pTHX_ OP *o)
79072805 7180{
27da23d5 7181 dVAR;
7918f24d
NC		 7182
7183 PERL_ARGS_ASSERT_NEWAVREF;
7184
ed6116ce
LW		 7185 if (o->op_type == OP_PADANY) {
7186 o->op_type = OP_PADAV;
22c35a8c 7187 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 7188 return o;
ed6116ce 7189 }
a2a5de95 7190 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
d1d15184 7191 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7192 "Using an array as a reference is deprecated");
a1063b2d 7193 }
79072805
LW		 7194 return newUNOP(OP_RV2AV, 0, scalar(o));
7195}
7196
7197OP *
864dbfa3 7198Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 7199{
82092f1d 7200 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 7201 return newUNOP(OP_NULL, 0, o);
748a9306 7202 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 7203}
7204
7205OP *
864dbfa3 7206Perl_newHVREF(pTHX_ OP *o)
79072805 7207{
27da23d5 7208 dVAR;
7918f24d
NC		 7209
7210 PERL_ARGS_ASSERT_NEWHVREF;
7211
ed6116ce
LW		 7212 if (o->op_type == OP_PADANY) {
7213 o->op_type = OP_PADHV;
22c35a8c 7214 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 7215 return o;
ed6116ce 7216 }
a2a5de95 7217 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
d1d15184 7218 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7219 "Using a hash as a reference is deprecated");
a1063b2d 7220 }
79072805
LW		 7221 return newUNOP(OP_RV2HV, 0, scalar(o));
7222}
7223
7224OP *
864dbfa3 7225Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 7226{
c07a80fd 7227 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 7228}
7229
7230OP *
864dbfa3 7231Perl_newSVREF(pTHX_ OP *o)
79072805 7232{
27da23d5 7233 dVAR;
7918f24d
NC		 7234
7235 PERL_ARGS_ASSERT_NEWSVREF;
7236
ed6116ce
LW		 7237 if (o->op_type == OP_PADANY) {
7238 o->op_type = OP_PADSV;
22c35a8c 7239 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 7240 return o;
ed6116ce 7241 }
79072805
LW		 7242 return newUNOP(OP_RV2SV, 0, scalar(o));
7243}
7244
61b743bb
DM		 7245/* Check routines. See the comments at the top of this file for details
7246 * on when these are called */
79072805
LW		 7247
7248OP *
cea2e8a9 7249Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 7250{
7918f24d
NC		 7251 PERL_ARGS_ASSERT_CK_ANONCODE;
7252
cc76b5cc 7253 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
eb8433b7 7254 if (!PL_madskills)
1d866c12 7255 cSVOPo->op_sv = NULL;
5dc0d613 7256 return o;
5f05dabc 7257}
7258
7259OP *
cea2e8a9 7260Perl_ck_bitop(pTHX_ OP *o)
55497cff 7261{
97aff369 7262 dVAR;
7918f24d
NC		 7263
7264 PERL_ARGS_ASSERT_CK_BITOP;
7265
d5ec2987 7266 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 7267 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7268 && (o->op_type == OP_BIT_OR
7269 || o->op_type == OP_BIT_AND
7270 || o->op_type == OP_BIT_XOR))
276b2a0c 7271 {
1df70142
AL		 7272 const OP * const left = cBINOPo->op_first;
7273 const OP * const right = left->op_sibling;
96a925ab
YST		 7274 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7275 (left->op_flags & OPf_PARENS) == 0) ||
7276 (OP_IS_NUMCOMPARE(right->op_type) &&
7277 (right->op_flags & OPf_PARENS) == 0))
a2a5de95
NC		 7278 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7279 "Possible precedence problem on bitwise %c operator",
7280 o->op_type == OP_BIT_OR ? '|'
7281 : o->op_type == OP_BIT_AND ? '&' : '^'
7282 );
276b2a0c 7283 }
5dc0d613 7284 return o;
55497cff 7285}
7286
7287OP *
cea2e8a9 7288Perl_ck_concat(pTHX_ OP *o)
79072805 7289{
0bd48802 7290 const OP * const kid = cUNOPo->op_first;
7918f24d
NC		 7291
7292 PERL_ARGS_ASSERT_CK_CONCAT;
96a5add6 7293 PERL_UNUSED_CONTEXT;
7918f24d 7294
df91b2c5
AE		 7295 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7296 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 7297 o->op_flags |= OPf_STACKED;
11343788 7298 return o;
79072805
LW		 7299}
7300
7301OP *
cea2e8a9 7302Perl_ck_spair(pTHX_ OP *o)
79072805 7303{
27da23d5 7304 dVAR;
7918f24d
NC		 7305
7306 PERL_ARGS_ASSERT_CK_SPAIR;
7307
11343788 7308 if (o->op_flags & OPf_KIDS) {
79072805 7309 OP* newop;
a0d0e21e 7310 OP* kid;
6867be6d 7311 const OPCODE type = o->op_type;
5dc0d613 7312 o = modkids(ck_fun(o), type);
11343788 7313 kid = cUNOPo->op_first;
a0d0e21e 7314 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 7315 if (newop) {
7316 const OPCODE type = newop->op_type;
7317 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7318 type == OP_PADAV || type == OP_PADHV ||
7319 type == OP_RV2AV || type == OP_RV2HV)
7320 return o;
a0d0e21e 7321 }
eb8433b7
NC		 7322#ifdef PERL_MAD
7323 op_getmad(kUNOP->op_first,newop,'K');
7324#else
a0d0e21e 7325 op_free(kUNOP->op_first);
eb8433b7 7326#endif
a0d0e21e
LW		 7327 kUNOP->op_first = newop;
7328 }
22c35a8c 7329 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 7330 return ck_fun(o);
a0d0e21e
LW		 7331}
7332
7333OP *
cea2e8a9 7334Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 7335{
7918f24d
NC		 7336 PERL_ARGS_ASSERT_CK_DELETE;
7337
11343788 7338 o = ck_fun(o);
5dc0d613 7339 o->op_private = 0;
11343788 7340 if (o->op_flags & OPf_KIDS) {
551405c4 7341 OP * const kid = cUNOPo->op_first;
01020589
GS		 7342 switch (kid->op_type) {
7343 case OP_ASLICE:
7344 o->op_flags |= OPf_SPECIAL;
7345 /* FALL THROUGH */
7346 case OP_HSLICE:
5dc0d613 7347 o->op_private |= OPpSLICE;
01020589
GS		 7348 break;
7349 case OP_AELEM:
7350 o->op_flags |= OPf_SPECIAL;
7351 /* FALL THROUGH */
7352 case OP_HELEM:
7353 break;
7354 default:
7355 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 7356 OP_DESC(o));
01020589 7357 }
7332a6c4
VP		 7358 if (kid->op_private & OPpLVAL_INTRO)
7359 o->op_private |= OPpLVAL_INTRO;
93c66552 7360 op_null(kid);
79072805 7361 }
11343788 7362 return o;
79072805
LW		 7363}
7364
7365OP *
96e176bf
CL		 7366Perl_ck_die(pTHX_ OP *o)
7367{
7918f24d
NC		 7368 PERL_ARGS_ASSERT_CK_DIE;
7369
96e176bf
CL		 7370#ifdef VMS
7371 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7372#endif
7373 return ck_fun(o);
7374}
7375
7376OP *
cea2e8a9 7377Perl_ck_eof(pTHX_ OP *o)
79072805 7378{
97aff369 7379 dVAR;
79072805 7380
7918f24d
NC		 7381 PERL_ARGS_ASSERT_CK_EOF;
7382
11343788
MB		 7383 if (o->op_flags & OPf_KIDS) {
7384 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 7385 OP * const newop
7386 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 7387#ifdef PERL_MAD
7388 op_getmad(o,newop,'O');
7389#else
11343788 7390 op_free(o);
eb8433b7
NC		 7391#endif
7392 o = newop;
8990e307 7393 }
11343788 7394 return ck_fun(o);
79072805 7395 }
11343788 7396 return o;
79072805
LW		 7397}
7398
7399OP *
cea2e8a9 7400Perl_ck_eval(pTHX_ OP *o)
79072805 7401{
27da23d5 7402 dVAR;
7918f24d
NC		 7403
7404 PERL_ARGS_ASSERT_CK_EVAL;
7405
3280af22 7406 PL_hints |= HINT_BLOCK_SCOPE;
11343788 7407 if (o->op_flags & OPf_KIDS) {
46c461b5 7408 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 7409
93a17b20 7410 if (!kid) {
11343788 7411 o->op_flags &= ~OPf_KIDS;
93c66552 7412 op_null(o);
79072805 7413 }
b14574b4 7414 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 7415 LOGOP *enter;
eb8433b7 7416#ifdef PERL_MAD
1d866c12 7417 OP* const oldo = o;
eb8433b7 7418#endif
79072805 7419
11343788 7420 cUNOPo->op_first = 0;
eb8433b7 7421#ifndef PERL_MAD
11343788 7422 op_free(o);
eb8433b7 7423#endif
79072805 7424
b7dc083c 7425 NewOp(1101, enter, 1, LOGOP);
79072805 7426 enter->op_type = OP_ENTERTRY;
22c35a8c 7427 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 7428 enter->op_private = 0;
7429
7430 /* establish postfix order */
7431 enter->op_next = (OP*)enter;
7432
2fcb4757 7433 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11343788 7434 o->op_type = OP_LEAVETRY;
22c35a8c 7435 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 7436 enter->op_other = o;
eb8433b7 7437 op_getmad(oldo,o,'O');
11343788 7438 return o;
79072805 7439 }
b5c19bd7 7440 else {
473986ff 7441 scalar((OP*)kid);
b5c19bd7
DM		 7442 PL_cv_has_eval = 1;
7443 }
79072805
LW		 7444 }
7445 else {
eb8433b7 7446#ifdef PERL_MAD
1d866c12 7447 OP* const oldo = o;
eb8433b7 7448#else
11343788 7449 op_free(o);
eb8433b7 7450#endif
54b9620d 7451 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
eb8433b7 7452 op_getmad(oldo,o,'O');
79072805 7453 }
3280af22 7454 o->op_targ = (PADOFFSET)PL_hints;
7168684c 7455 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
996c9baa
VP		 7456 /* Store a copy of %^H that pp_entereval can pick up. */
7457 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
defdfed5 7458 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
0d863452
RH		 7459 cUNOPo->op_first->op_sibling = hhop;
7460 o->op_private |= OPpEVAL_HAS_HH;
7461 }
11343788 7462 return o;
79072805
LW		 7463}
7464
7465OP *
d98f61e7
GS		 7466Perl_ck_exit(pTHX_ OP *o)
7467{
7918f24d
NC		 7468 PERL_ARGS_ASSERT_CK_EXIT;
7469
d98f61e7 7470#ifdef VMS
551405c4 7471 HV * const table = GvHV(PL_hintgv);
d98f61e7 7472 if (table) {
a4fc7abc 7473 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 7474 if (svp && *svp && SvTRUE(*svp))
7475 o->op_private |= OPpEXIT_VMSISH;
7476 }
96e176bf 7477 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 7478#endif
7479 return ck_fun(o);
7480}
7481
7482OP *
cea2e8a9 7483Perl_ck_exec(pTHX_ OP *o)
79072805 7484{
7918f24d
NC		 7485 PERL_ARGS_ASSERT_CK_EXEC;
7486
11343788 7487 if (o->op_flags & OPf_STACKED) {
6867be6d 7488 OP *kid;
11343788
MB		 7489 o = ck_fun(o);
7490 kid = cUNOPo->op_first->op_sibling;
8990e307 7491 if (kid->op_type == OP_RV2GV)
93c66552 7492 op_null(kid);
79072805 7493 }
463ee0b2 7494 else
11343788
MB		 7495 o = listkids(o);
7496 return o;
79072805
LW		 7497}
7498
7499OP *
cea2e8a9 7500Perl_ck_exists(pTHX_ OP *o)
5f05dabc 7501{
97aff369 7502 dVAR;
7918f24d
NC		 7503
7504 PERL_ARGS_ASSERT_CK_EXISTS;
7505
5196be3e
MB		 7506 o = ck_fun(o);
7507 if (o->op_flags & OPf_KIDS) {
46c461b5 7508 OP * const kid = cUNOPo->op_first;
afebc493
GS		 7509 if (kid->op_type == OP_ENTERSUB) {
7510 (void) ref(kid, o->op_type);
13765c85
DM		 7511 if (kid->op_type != OP_RV2CV
7512 && !(PL_parser && PL_parser->error_count))
afebc493 7513 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 7514 OP_DESC(o));
afebc493
GS		 7515 o->op_private |= OPpEXISTS_SUB;
7516 }
7517 else if (kid->op_type == OP_AELEM)
01020589
GS		 7518 o->op_flags |= OPf_SPECIAL;
7519 else if (kid->op_type != OP_HELEM)
b0fdf69e 7520 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
53e06cf0 7521 OP_DESC(o));
93c66552 7522 op_null(kid);
5f05dabc 7523 }
5196be3e 7524 return o;
5f05dabc 7525}
7526
79072805 7527OP *
cea2e8a9 7528Perl_ck_rvconst(pTHX_ register OP *o)
79072805 7529{
27da23d5 7530 dVAR;
0bd48802 7531 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 7532
7918f24d
NC		 7533 PERL_ARGS_ASSERT_CK_RVCONST;
7534
3280af22 7535 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 7536 if (o->op_type == OP_RV2CV)
7537 o->op_private &= ~1;
7538
79072805 7539 if (kid->op_type == OP_CONST) {
44a8e56a 7540 int iscv;
7541 GV *gv;
504618e9 7542 SV * const kidsv = kid->op_sv;
44a8e56a 7543
779c5bc9
GS		 7544 /* Is it a constant from cv_const_sv()? */
7545 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 7546 SV * const rsv = SvRV(kidsv);
42d0e0b7 7547 const svtype type = SvTYPE(rsv);
bd61b366 7548 const char *badtype = NULL;
779c5bc9
GS		 7549
7550 switch (o->op_type) {
7551 case OP_RV2SV:
42d0e0b7 7552 if (type > SVt_PVMG)
779c5bc9
GS		 7553 badtype = "a SCALAR";
7554 break;
7555 case OP_RV2AV:
42d0e0b7 7556 if (type != SVt_PVAV)
779c5bc9
GS		 7557 badtype = "an ARRAY";
7558 break;
7559 case OP_RV2HV:
42d0e0b7 7560 if (type != SVt_PVHV)
779c5bc9 7561 badtype = "a HASH";
779c5bc9
GS		 7562 break;
7563 case OP_RV2CV:
42d0e0b7 7564 if (type != SVt_PVCV)
779c5bc9
GS		 7565 badtype = "a CODE";
7566 break;
7567 }
7568 if (badtype)
cea2e8a9 7569 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 7570 return o;
7571 }
ce10b5d1 7572 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 7573 const char *badthing;
5dc0d613 7574 switch (o->op_type) {
44a8e56a 7575 case OP_RV2SV:
7576 badthing = "a SCALAR";
7577 break;
7578 case OP_RV2AV:
7579 badthing = "an ARRAY";
7580 break;
7581 case OP_RV2HV:
7582 badthing = "a HASH";
7583 break;
5f66b61c
AL		 7584 default:
7585 badthing = NULL;
7586 break;
44a8e56a 7587 }
7588 if (badthing)
1c846c1f 7589 Perl_croak(aTHX_
95b63a38 7590 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 7591 SVfARG(kidsv), badthing);
44a8e56a 7592 }
93233ece
CS		 7593 /*
7594 * This is a little tricky. We only want to add the symbol if we
7595 * didn't add it in the lexer. Otherwise we get duplicate strict
7596 * warnings. But if we didn't add it in the lexer, we must at
7597 * least pretend like we wanted to add it even if it existed before,
7598 * or we get possible typo warnings. OPpCONST_ENTERED says
7599 * whether the lexer already added THIS instance of this symbol.
7600 */
5196be3e 7601 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 7602 do {
7a5fd60d 7603 gv = gv_fetchsv(kidsv,
748a9306 7604 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 7605 iscv
7606 ? SVt_PVCV
11343788 7607 : o->op_type == OP_RV2SV
a0d0e21e 7608 ? SVt_PV
11343788 7609 : o->op_type == OP_RV2AV
a0d0e21e 7610 ? SVt_PVAV
11343788 7611 : o->op_type == OP_RV2HV
a0d0e21e
LW		 7612 ? SVt_PVHV
7613 : SVt_PVGV);
93233ece
CS		 7614 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7615 if (gv) {
7616 kid->op_type = OP_GV;
7617 SvREFCNT_dec(kid->op_sv);
350de78d 7618#ifdef USE_ITHREADS
638eceb6 7619 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 7620 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 7621 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 7622 GvIN_PAD_on(gv);
ad64d0ec 7623 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
350de78d 7624#else
b37c2d43 7625 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 7626#endif
23f1ca44 7627 kid->op_private = 0;
76cd736e 7628 kid->op_ppaddr = PL_ppaddr[OP_GV];
2acc3314
FC		 7629 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7630 SvFAKE_off(gv);
a0d0e21e 7631 }
79072805 7632 }
11343788 7633 return o;
79072805
LW		 7634}
7635
7636OP *
cea2e8a9 7637Perl_ck_ftst(pTHX_ OP *o)
79072805 7638{
27da23d5 7639 dVAR;
6867be6d 7640 const I32 type = o->op_type;
79072805 7641
7918f24d
NC		 7642 PERL_ARGS_ASSERT_CK_FTST;
7643
d0dca557 7644 if (o->op_flags & OPf_REF) {
6f207bd3 7645 NOOP;
d0dca557
JD		 7646 }
7647 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 7648 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 7649 const OPCODE kidtype = kid->op_type;
79072805 7650
1496a290 7651 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 7652 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 7653 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 7654#ifdef PERL_MAD
7655 op_getmad(o,newop,'O');
7656#else
11343788 7657 op_free(o);
eb8433b7 7658#endif
1d866c12 7659 return newop;
79072805 7660 }
6ecf81d6 7661 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
1af34c76 7662 o->op_private |= OPpFT_ACCESS;
ef69c8fc 7663 if (PL_check[kidtype] == Perl_ck_ftst
bbd91306 7664 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
fbb0b3b3 7665 o->op_private |= OPpFT_STACKED;
bbd91306
GG		 7666 kid->op_private |= OPpFT_STACKING;
7667 }
79072805
LW		 7668 }
7669 else {
eb8433b7 7670#ifdef PERL_MAD
1d866c12 7671 OP* const oldo = o;
eb8433b7 7672#else
11343788 7673 op_free(o);
eb8433b7 7674#endif
79072805 7675 if (type == OP_FTTTY)
8fde6460 7676 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 7677 else
d0dca557 7678 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 7679 op_getmad(oldo,o,'O');
79072805 7680 }
11343788 7681 return o;
79072805
LW		 7682}
7683
7684OP *
cea2e8a9 7685Perl_ck_fun(pTHX_ OP *o)
79072805 7686{
97aff369 7687 dVAR;
6867be6d 7688 const int type = o->op_type;
22c35a8c 7689 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 7690
7918f24d
NC		 7691 PERL_ARGS_ASSERT_CK_FUN;
7692
11343788 7693 if (o->op_flags & OPf_STACKED) {
79072805
LW		 7694 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7695 oa &= ~OA_OPTIONAL;
7696 else
11343788 7697 return no_fh_allowed(o);
79072805
LW		 7698 }
7699
11343788 7700 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 7701 OP **tokid = &cLISTOPo->op_first;
7702 register OP *kid = cLISTOPo->op_first;
7703 OP *sibl;
7704 I32 numargs = 0;
ea5703f4 7705 bool seen_optional = FALSE;
6867be6d 7706
8990e307 7707 if (kid->op_type == OP_PUSHMARK ||
155aba94 7708 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 7709 {
79072805
LW		 7710 tokid = &kid->op_sibling;
7711 kid = kid->op_sibling;
7712 }
f6a16869
FC		 7713 if (kid && kid->op_type == OP_COREARGS) {
7714 bool optional = FALSE;
7715 while (oa) {
7716 numargs++;
7717 if (oa & OA_OPTIONAL) optional = TRUE;
7718 oa = oa >> 4;
7719 }
7720 if (optional) o->op_private |= numargs;
7721 return o;
7722 }
79072805 7723
ea5703f4 7724 while (oa) {
72ec8a82 7725 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
ea5703f4
FC		 7726 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
7727 *tokid = kid = newDEFSVOP();
7728 seen_optional = TRUE;
7729 }
7730 if (!kid) break;
7731
79072805
LW		 7732 numargs++;
7733 sibl = kid->op_sibling;
eb8433b7
NC		 7734#ifdef PERL_MAD
7735 if (!sibl && kid->op_type == OP_STUB) {
7736 numargs--;
7737 break;
7738 }
7739#endif
79072805
LW		 7740 switch (oa & 7) {
7741 case OA_SCALAR:
62c18ce2
GS		 7742 /* list seen where single (scalar) arg expected? */
7743 if (numargs == 1 && !(oa >> 4)
7744 && kid->op_type == OP_LIST && type != OP_SCALAR)
7745 {
7746 return too_many_arguments(o,PL_op_desc[type]);
7747 }
79072805
LW		 7748 scalar(kid);
7749 break;
7750 case OA_LIST:
7751 if (oa < 16) {
7752 kid = 0;
7753 continue;
7754 }
7755 else
7756 list(kid);
7757 break;
7758 case OA_AVREF:
936edb8b 7759 if ((type == OP_PUSH || type == OP_UNSHIFT)
a2a5de95
NC		 7760 && !kid->op_sibling)
7761 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7762 "Useless use of %s with no values",
7763 PL_op_desc[type]);
b2ffa427 7764
79072805 7765 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 7766 (kid->op_private & OPpCONST_BARE))
7767 {
551405c4 7768 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 7769 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
d1d15184 7770 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 7771 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7772 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 7773#ifdef PERL_MAD
7774 op_getmad(kid,newop,'K');
7775#else
79072805 7776 op_free(kid);
eb8433b7 7777#endif
79072805
LW		 7778 kid = newop;
7779 kid->op_sibling = sibl;
7780 *tokid = kid;
7781 }
d4fc4415
FC		 7782 else if (kid->op_type == OP_CONST
7783 && ( !SvROK(cSVOPx_sv(kid))
7784 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7785 )
35cd451c 7786 bad_type(numargs, "array", PL_op_desc[type], kid);
d4fc4415
FC		 7787 /* Defer checks to run-time if we have a scalar arg */
7788 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7789 op_lvalue(kid, type);
7790 else scalar(kid);
79072805
LW		 7791 break;
7792 case OA_HVREF:
7793 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 7794 (kid->op_private & OPpCONST_BARE))
7795 {
551405c4 7796 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 7797 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
d1d15184 7798 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 7799 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7800 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 7801#ifdef PERL_MAD
7802 op_getmad(kid,newop,'K');
7803#else
79072805 7804 op_free(kid);
eb8433b7 7805#endif
79072805
LW		 7806 kid = newop;
7807 kid->op_sibling = sibl;
7808 *tokid = kid;
7809 }
8990e307 7810 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 7811 bad_type(numargs, "hash", PL_op_desc[type], kid);
3ad73efd 7812 op_lvalue(kid, type);
79072805
LW		 7813 break;
7814 case OA_CVREF:
7815 {
551405c4 7816 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805 7817 kid->op_sibling = 0;
5983a79d 7818 LINKLIST(kid);
79072805
LW		 7819 newop->op_next = newop;
7820 kid = newop;
7821 kid->op_sibling = sibl;
7822 *tokid = kid;
7823 }
7824 break;
7825 case OA_FILEREF:
c340be78 7826 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 7827 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 7828 (kid->op_private & OPpCONST_BARE))
7829 {
0bd48802 7830 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 7831 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 7832 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 7833 kid == cLISTOPo->op_last)
364daeac 7834 cLISTOPo->op_last = newop;
eb8433b7
NC		 7835#ifdef PERL_MAD
7836 op_getmad(kid,newop,'K');
7837#else
79072805 7838 op_free(kid);
eb8433b7 7839#endif
79072805
LW		 7840 kid = newop;
7841 }
1ea32a52
GS		 7842 else if (kid->op_type == OP_READLINE) {
7843 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 7844 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 7845 }
79072805 7846 else {
35cd451c 7847 I32 flags = OPf_SPECIAL;
a6c40364 7848 I32 priv = 0;
2c8ac474
GS		 7849 PADOFFSET targ = 0;
7850
35cd451c 7851 /* is this op a FH constructor? */
853846ea 7852 if (is_handle_constructor(o,numargs)) {
bd61b366 7853 const char *name = NULL;
dd2155a4 7854 STRLEN len = 0;
2dc9cdca 7855 U32 name_utf8 = 0;
2c8ac474
GS		 7856
7857 flags = 0;
7858 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 7859 * need to "prove" flag does not mean something
7860 * else already - NI-S 1999/05/07
2c8ac474
GS		 7861 */
7862 priv = OPpDEREF;
7863 if (kid->op_type == OP_PADSV) {
f8503592
NC		 7864 SV *const namesv
7865 = PAD_COMPNAME_SV(kid->op_targ);
7866 name = SvPV_const(namesv, len);
2dc9cdca 7867 name_utf8 = SvUTF8(namesv);
2c8ac474
GS		 7868 }
7869 else if (kid->op_type == OP_RV2SV
7870 && kUNOP->op_first->op_type == OP_GV)
7871 {
0bd48802 7872 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 7873 name = GvNAME(gv);
7874 len = GvNAMELEN(gv);
2dc9cdca 7875 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
2c8ac474 7876 }
afd1915d
GS		 7877 else if (kid->op_type == OP_AELEM
7878 || kid->op_type == OP_HELEM)
7879 {
735fec84 7880 OP *firstop;
551405c4 7881 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 7882 name = NULL;
551405c4 7883 if (op) {
a0714e2c 7884 SV *tmpstr = NULL;
551405c4 7885 const char * const a =
666ea192
JH		 7886 kid->op_type == OP_AELEM ?
7887 "[]" : "{}";
0c4b0a3f
JH		 7888 if (((op->op_type == OP_RV2AV) ||
7889 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 7890 (firstop = ((UNOP*)op)->op_first) &&
7891 (firstop->op_type == OP_GV)) {
0c4b0a3f 7892 /* packagevar $a[] or $h{} */
735fec84 7893 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 7894 if (gv)
7895 tmpstr =
7896 Perl_newSVpvf(aTHX_
7897 "%s%c...%c",
7898 GvNAME(gv),
7899 a[0], a[1]);
7900 }
7901 else if (op->op_type == OP_PADAV
7902 || op->op_type == OP_PADHV) {
7903 /* lexicalvar $a[] or $h{} */
551405c4 7904 const char * const padname =
0c4b0a3f
JH		 7905 PAD_COMPNAME_PV(op->op_targ);
7906 if (padname)
7907 tmpstr =
7908 Perl_newSVpvf(aTHX_
7909 "%s%c...%c",
7910 padname + 1,
7911 a[0], a[1]);
0c4b0a3f
JH		 7912 }
7913 if (tmpstr) {
93524f2b 7914 name = SvPV_const(tmpstr, len);
2dc9cdca 7915 name_utf8 = SvUTF8(tmpstr);
0c4b0a3f
JH		 7916 sv_2mortal(tmpstr);
7917 }
7918 }
7919 if (!name) {
7920 name = "__ANONIO__";
7921 len = 10;
7922 }
3ad73efd 7923 op_lvalue(kid, type);
afd1915d 7924 }
2c8ac474
GS		 7925 if (name) {
7926 SV *namesv;
7927 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 7928 namesv = PAD_SVl(targ);
862a34c6 7929 SvUPGRADE(namesv, SVt_PV);
2c8ac474 7930 if (*name != '$')
76f68e9b 7931 sv_setpvs(namesv, "$");
2c8ac474 7932 sv_catpvn(namesv, name, len);
2dc9cdca 7933 if ( name_utf8 ) SvUTF8_on(namesv);
2c8ac474 7934 }
853846ea 7935 }
79072805 7936 kid->op_sibling = 0;
35cd451c 7937 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 7938 kid->op_targ = targ;
7939 kid->op_private |= priv;
79072805
LW		 7940 }
7941 kid->op_sibling = sibl;
7942 *tokid = kid;
7943 }
7944 scalar(kid);
7945 break;
7946 case OA_SCALARREF:
3ad73efd 7947 op_lvalue(scalar(kid), type);
79072805
LW		 7948 break;
7949 }
7950 oa >>= 4;
7951 tokid = &kid->op_sibling;
7952 kid = kid->op_sibling;
7953 }
eb8433b7
NC		 7954#ifdef PERL_MAD
7955 if (kid && kid->op_type != OP_STUB)
7956 return too_many_arguments(o,OP_DESC(o));
7957 o->op_private |= numargs;
7958#else
7959 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 7960 o->op_private |= numargs;
79072805 7961 if (kid)
53e06cf0 7962 return too_many_arguments(o,OP_DESC(o));
eb8433b7 7963#endif
11343788 7964 listkids(o);
79072805 7965 }
22c35a8c 7966 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 7967#ifdef PERL_MAD
c7fe699d 7968 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 7969 op_getmad(o,newop,'O');
c7fe699d 7970 return newop;
c56915e3 7971#else
c7fe699d 7972 /* Ordering of these two is important to keep f_map.t passing. */
11343788 7973 op_free(o);
c7fe699d 7974 return newUNOP(type, 0, newDEFSVOP());
c56915e3 7975#endif
a0d0e21e
LW		 7976 }
7977
79072805
LW		 7978 if (oa) {
7979 while (oa & OA_OPTIONAL)
7980 oa >>= 4;
7981 if (oa && oa != OA_LIST)
53e06cf0 7982 return too_few_arguments(o,OP_DESC(o));
79072805 7983 }
11343788 7984 return o;
79072805
LW		 7985}
7986
7987OP *
cea2e8a9 7988Perl_ck_glob(pTHX_ OP *o)
79072805 7989{
27da23d5 7990 dVAR;
fb73857a 7991 GV *gv;
d67594ff 7992 const bool core = o->op_flags & OPf_SPECIAL;
fb73857a 7993
7918f24d
NC		 7994 PERL_ARGS_ASSERT_CK_GLOB;
7995
649da076 7996 o = ck_fun(o);
1f2bfc8a 7997 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
bd31915d 7998 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
fb73857a 7999
d67594ff
FC		 8000 if (core) gv = NULL;
8001 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 8002 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8003 {
5c1737d1 8004 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 8005 }
b1cb66bf 8006
52bb0670 8007#if !defined(PERL_EXTERNAL_GLOB)
f444d496 8008 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
72b16652 8009 ENTER;
00ca71c1 8010 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
a0714e2c 8011 newSVpvs("File::Glob"), NULL, NULL, NULL);
72b16652
GS		 8012 LEAVE;
8013 }
d67594ff 8014#endif /* !PERL_EXTERNAL_GLOB */
72b16652 8015
b9f751c0 8016 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
d1bea3d8
DM		 8017 /* convert
8018 * glob
8019 * \ null - const(wildcard)
8020 * into
8021 * null
8022 * \ enter
8023 * \ list
8024 * \ mark - glob - rv2cv
8025 * | \ gv(CORE::GLOBAL::glob)
8026 * |
8027 * \ null - const(wildcard) - const(ix)
8028 */
8029 o->op_flags |= OPf_SPECIAL;
9426e1a5 8030 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
2fcb4757 8031 op_append_elem(OP_GLOB, o,
80252599 8032 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
d1bea3d8 8033 o = newLISTOP(OP_LIST, 0, o, NULL);
1f2bfc8a 8034 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 8035 op_append_elem(OP_LIST, o,
1f2bfc8a
MB		 8036 scalar(newUNOP(OP_RV2CV, 0,
8037 newGVOP(OP_GV, 0, gv)))));
d58bf5aa 8038 o = newUNOP(OP_NULL, 0, ck_subr(o));
d1bea3d8 8039 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
d58bf5aa 8040 return o;
b1cb66bf 8041 }
d67594ff 8042 else o->op_flags &= ~OPf_SPECIAL;
b1cb66bf 8043 gv = newGVgen("main");
a0d0e21e 8044 gv_IOadd(gv);
d67594ff
FC		 8045#ifndef PERL_EXTERNAL_GLOB
8046 sv_setiv(GvSVn(gv),PL_glob_index++);
8047#endif
2fcb4757 8048 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11343788 8049 scalarkids(o);
649da076 8050 return o;
79072805
LW		 8051}
8052
8053OP *
cea2e8a9 8054Perl_ck_grep(pTHX_ OP *o)
79072805 8055{
27da23d5 8056 dVAR;
03ca120d 8057 LOGOP *gwop = NULL;
79072805 8058 OP *kid;
6867be6d 8059 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 8060 PADOFFSET offset;
79072805 8061
7918f24d
NC		 8062 PERL_ARGS_ASSERT_CK_GREP;
8063
22c35a8c 8064 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 8065 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 8066
11343788 8067 if (o->op_flags & OPf_STACKED) {
a0d0e21e 8068 OP* k;
11343788 8069 o = ck_sort(o);
f6435df3
GG		 8070 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8071 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8072 return no_fh_allowed(o);
8073 for (k = kid; k; k = k->op_next) {
a0d0e21e
LW		 8074 kid = k;
8075 }
03ca120d 8076 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 8077 kid->op_next = (OP*)gwop;
11343788 8078 o->op_flags &= ~OPf_STACKED;
93a17b20 8079 }
11343788 8080 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 8081 if (type == OP_MAPWHILE)
8082 list(kid);
8083 else
8084 scalar(kid);
11343788 8085 o = ck_fun(o);
13765c85 8086 if (PL_parser && PL_parser->error_count)
11343788 8087 return o;
aeea060c 8088 kid = cLISTOPo->op_first->op_sibling;
79072805 8089 if (kid->op_type != OP_NULL)
cea2e8a9 8090 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 8091 kid = kUNOP->op_first;
8092
03ca120d
MHM		 8093 if (!gwop)
8094 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 8095 gwop->op_type = type;
22c35a8c 8096 gwop->op_ppaddr = PL_ppaddr[type];
11343788 8097 gwop->op_first = listkids(o);
79072805 8098 gwop->op_flags |= OPf_KIDS;
79072805 8099 gwop->op_other = LINKLIST(kid);
79072805 8100 kid->op_next = (OP*)gwop;
cc76b5cc 8101 offset = pad_findmy_pvs("$_", 0);
00b1698f 8102 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 8103 o->op_private = gwop->op_private = 0;
8104 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8105 }
8106 else {
8107 o->op_private = gwop->op_private = OPpGREP_LEX;
8108 gwop->op_targ = o->op_targ = offset;
8109 }
79072805 8110
11343788 8111 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 8112 if (!kid || !kid->op_sibling)
53e06cf0 8113 return too_few_arguments(o,OP_DESC(o));
a0d0e21e 8114 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 8115 op_lvalue(kid, OP_GREPSTART);
a0d0e21e 8116
79072805
LW		 8117 return (OP*)gwop;
8118}
8119
8120OP *
cea2e8a9 8121Perl_ck_index(pTHX_ OP *o)
79072805 8122{
7918f24d
NC		 8123 PERL_ARGS_ASSERT_CK_INDEX;
8124
11343788
MB		 8125 if (o->op_flags & OPf_KIDS) {
8126 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 8127 if (kid)
8128 kid = kid->op_sibling; /* get past "big" */
3b36395d
DM		 8129 if (kid && kid->op_type == OP_CONST) {
8130 const bool save_taint = PL_tainted;
2779dcf1 8131 fbm_compile(((SVOP*)kid)->op_sv, 0);
3b36395d
DM		 8132 PL_tainted = save_taint;
8133 }
79072805 8134 }
11343788 8135 return ck_fun(o);
79072805
LW		 8136}
8137
8138OP *
cea2e8a9 8139Perl_ck_lfun(pTHX_ OP *o)
79072805 8140{
6867be6d 8141 const OPCODE type = o->op_type;
7918f24d
NC		 8142
8143 PERL_ARGS_ASSERT_CK_LFUN;
8144
5dc0d613 8145 return modkids(ck_fun(o), type);
79072805
LW		 8146}
8147
8148OP *
cea2e8a9 8149Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 8150{
7918f24d
NC		 8151 PERL_ARGS_ASSERT_CK_DEFINED;
8152
a2a5de95 8153 if ((o->op_flags & OPf_KIDS)) {
d0334bed
GS		 8154 switch (cUNOPo->op_first->op_type) {
8155 case OP_RV2AV:
a8739d98
JH		 8156 /* This is needed for
8157 if (defined %stash::)
8158 to work. Do not break Tk.
8159 */
1c846c1f 8160 break; /* Globals via GV can be undef */
d0334bed
GS		 8161 case OP_PADAV:
8162 case OP_AASSIGN: /* Is this a good idea? */
d1d15184 8163 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8164 "defined(@array) is deprecated");
d1d15184 8165 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8166 "\t(Maybe you should just omit the defined()?)\n");
69794302 8167 break;
d0334bed
GS		 8168 case OP_RV2HV:
8169 case OP_PADHV:
d1d15184 8170 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8171 "defined(%%hash) is deprecated");
d1d15184 8172 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 8173 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 8174 break;
8175 default:
8176 /* no warning */
8177 break;
8178 }
69794302
MJD		 8179 }
8180 return ck_rfun(o);
8181}
8182
8183OP *
e4b7ebf3
RGS		 8184Perl_ck_readline(pTHX_ OP *o)
8185{
7918f24d
NC		 8186 PERL_ARGS_ASSERT_CK_READLINE;
8187
e4b7ebf3
RGS		 8188 if (!(o->op_flags & OPf_KIDS)) {
8189 OP * const newop
8190 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8191#ifdef PERL_MAD
8192 op_getmad(o,newop,'O');
8193#else
8194 op_free(o);
8195#endif
8196 return newop;
8197 }
8198 return o;
8199}
8200
8201OP *
cea2e8a9 8202Perl_ck_rfun(pTHX_ OP *o)
8990e307 8203{
6867be6d 8204 const OPCODE type = o->op_type;
7918f24d
NC		 8205
8206 PERL_ARGS_ASSERT_CK_RFUN;
8207
5dc0d613 8208 return refkids(ck_fun(o), type);
8990e307
LW		 8209}
8210
8211OP *
cea2e8a9 8212Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 8213{
8214 register OP *kid;
aeea060c 8215
7918f24d
NC		 8216 PERL_ARGS_ASSERT_CK_LISTIOB;
8217
11343788 8218 kid = cLISTOPo->op_first;
79072805 8219 if (!kid) {
11343788
MB		 8220 o = force_list(o);
8221 kid = cLISTOPo->op_first;
79072805
LW		 8222 }
8223 if (kid->op_type == OP_PUSHMARK)
8224 kid = kid->op_sibling;
11343788 8225 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 8226 kid = kid->op_sibling;
8227 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8228 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 8229 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 8230 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 8231 cLISTOPo->op_first->op_sibling = kid;
8232 cLISTOPo->op_last = kid;
79072805
LW		 8233 kid = kid->op_sibling;
8234 }
8235 }
b2ffa427 8236
79072805 8237 if (!kid)
2fcb4757 8238 op_append_elem(o->op_type, o, newDEFSVOP());
79072805 8239
2de3dbcc 8240 return listkids(o);
bbce6d69 8241}
8242
8243OP *
0d863452
RH		 8244Perl_ck_smartmatch(pTHX_ OP *o)
8245{
97aff369 8246 dVAR;
a4e74480 8247 PERL_ARGS_ASSERT_CK_SMARTMATCH;
0d863452
RH		 8248 if (0 == (o->op_flags & OPf_SPECIAL)) {
8249 OP *first = cBINOPo->op_first;
8250 OP *second = first->op_sibling;
8251
8252 /* Implicitly take a reference to an array or hash */
5f66b61c 8253 first->op_sibling = NULL;
0d863452
RH		 8254 first = cBINOPo->op_first = ref_array_or_hash(first);
8255 second = first->op_sibling = ref_array_or_hash(second);
8256
8257 /* Implicitly take a reference to a regular expression */
8258 if (first->op_type == OP_MATCH) {
8259 first->op_type = OP_QR;
8260 first->op_ppaddr = PL_ppaddr[OP_QR];
8261 }
8262 if (second->op_type == OP_MATCH) {
8263 second->op_type = OP_QR;
8264 second->op_ppaddr = PL_ppaddr[OP_QR];
8265 }
8266 }
8267
8268 return o;
8269}
8270
8271
8272OP *
b162f9ea
IZ		 8273Perl_ck_sassign(pTHX_ OP *o)
8274{
3088bf26 8275 dVAR;
1496a290 8276 OP * const kid = cLISTOPo->op_first;
7918f24d
NC		 8277
8278 PERL_ARGS_ASSERT_CK_SASSIGN;
8279
b162f9ea
IZ		 8280 /* has a disposable target? */
8281 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 8282 && !(kid->op_flags & OPf_STACKED)
8283 /* Cannot steal the second time! */
1b438339
GG		 8284 && !(kid->op_private & OPpTARGET_MY)
8285 /* Keep the full thing for madskills */
8286 && !PL_madskills
8287 )
b162f9ea 8288 {
551405c4 8289 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 8290
8291 /* Can just relocate the target. */
2c2d71f5
JH		 8292 if (kkid && kkid->op_type == OP_PADSV
8293 && !(kkid->op_private & OPpLVAL_INTRO))
8294 {
b162f9ea 8295 kid->op_targ = kkid->op_targ;
743e66e6 8296 kkid->op_targ = 0;
b162f9ea
IZ		 8297 /* Now we do not need PADSV and SASSIGN. */
8298 kid->op_sibling = o->op_sibling; /* NULL */
8299 cLISTOPo->op_first = NULL;
8300 op_free(o);
8301 op_free(kkid);
8302 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8303 return kid;
8304 }
8305 }
c5917253
NC		 8306 if (kid->op_sibling) {
8307 OP *kkid = kid->op_sibling;
a1fba7eb
FC		 8308 /* For state variable assignment, kkid is a list op whose op_last
8309 is a padsv. */
8310 if ((kkid->op_type == OP_PADSV ||
8311 (kkid->op_type == OP_LIST &&
8312 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8313 )
8314 )
c5917253
NC		 8315 && (kkid->op_private & OPpLVAL_INTRO)
8316 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8317 const PADOFFSET target = kkid->op_targ;
8318 OP *const other = newOP(OP_PADSV,
8319 kkid->op_flags
8320 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8321 OP *const first = newOP(OP_NULL, 0);
8322 OP *const nullop = newCONDOP(0, first, o, other);
8323 OP *const condop = first->op_next;
8324 /* hijacking PADSTALE for uninitialized state variables */
8325 SvPADSTALE_on(PAD_SVl(target));
8326
8327 condop->op_type = OP_ONCE;
8328 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8329 condop->op_targ = target;
8330 other->op_targ = target;
8331
95562366 8332 /* Because we change the type of the op here, we will skip the
486ec47a 8333 assignment binop->op_last = binop->op_first->op_sibling; at the
95562366
NC		 8334 end of Perl_newBINOP(). So need to do it here. */
8335 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8336
c5917253
NC		 8337 return nullop;
8338 }
8339 }
b162f9ea
IZ		 8340 return o;
8341}
8342
8343OP *
cea2e8a9 8344Perl_ck_match(pTHX_ OP *o)
79072805 8345{
97aff369 8346 dVAR;
7918f24d
NC		 8347
8348 PERL_ARGS_ASSERT_CK_MATCH;
8349
0d863452 8350 if (o->op_type != OP_QR && PL_compcv) {
cc76b5cc 8351 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 8352 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 8353 o->op_targ = offset;
8354 o->op_private |= OPpTARGET_MY;
8355 }
8356 }
8357 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8358 o->op_private |= OPpRUNTIME;
11343788 8359 return o;
79072805
LW		 8360}
8361
8362OP *
f5d5a27c
CS		 8363Perl_ck_method(pTHX_ OP *o)
8364{
551405c4 8365 OP * const kid = cUNOPo->op_first;
7918f24d
NC		 8366
8367 PERL_ARGS_ASSERT_CK_METHOD;
8368
f5d5a27c
CS		 8369 if (kid->op_type == OP_CONST) {
8370 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 8371 const char * const method = SvPVX_const(sv);
8372 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 8373 OP *cmop;
1c846c1f 8374 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
c60dbbc3 8375 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
1c846c1f
NIS		 8376 }
8377 else {
a0714e2c 8378 kSVOP->op_sv = NULL;
1c846c1f 8379 }
f5d5a27c 8380 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 8381#ifdef PERL_MAD
8382 op_getmad(o,cmop,'O');
8383#else
f5d5a27c 8384 op_free(o);
eb8433b7 8385#endif
f5d5a27c
CS		 8386 return cmop;
8387 }
8388 }
8389 return o;
8390}
8391
8392OP *
cea2e8a9 8393Perl_ck_null(pTHX_ OP *o)
79072805 8394{
7918f24d 8395 PERL_ARGS_ASSERT_CK_NULL;
96a5add6 8396 PERL_UNUSED_CONTEXT;
11343788 8397 return o;
79072805
LW		 8398}
8399
8400OP *
16fe6d59
GS		 8401Perl_ck_open(pTHX_ OP *o)
8402{
97aff369 8403 dVAR;
551405c4 8404 HV * const table = GvHV(PL_hintgv);
7918f24d
NC		 8405
8406 PERL_ARGS_ASSERT_CK_OPEN;
8407
16fe6d59 8408 if (table) {
a4fc7abc 8409 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 8410 if (svp && *svp) {
a79b25b7
VP		 8411 STRLEN len = 0;
8412 const char *d = SvPV_const(*svp, len);
8413 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 8414 if (mode & O_BINARY)
8415 o->op_private |= OPpOPEN_IN_RAW;
8416 else if (mode & O_TEXT)
8417 o->op_private |= OPpOPEN_IN_CRLF;
8418 }
8419
a4fc7abc 8420 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 8421 if (svp && *svp) {
a79b25b7
VP		 8422 STRLEN len = 0;
8423 const char *d = SvPV_const(*svp, len);
8424 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 8425 if (mode & O_BINARY)
8426 o->op_private |= OPpOPEN_OUT_RAW;
8427 else if (mode & O_TEXT)
8428 o->op_private |= OPpOPEN_OUT_CRLF;
8429 }
8430 }
8d7403e6
RGS		 8431 if (o->op_type == OP_BACKTICK) {
8432 if (!(o->op_flags & OPf_KIDS)) {
e4b7ebf3
RGS		 8433 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8434#ifdef PERL_MAD
8435 op_getmad(o,newop,'O');
8436#else
8d7403e6 8437 op_free(o);
e4b7ebf3
RGS		 8438#endif
8439 return newop;
8d7403e6 8440 }
16fe6d59 8441 return o;
8d7403e6 8442 }
3b82e551
JH		 8443 {
8444 /* In case of three-arg dup open remove strictness
8445 * from the last arg if it is a bareword. */
551405c4
AL		 8446 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8447 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 8448 OP *oa;
b15aece3 8449 const char *mode;
3b82e551
JH		 8450
8451 if ((last->op_type == OP_CONST) && /* The bareword. */
8452 (last->op_private & OPpCONST_BARE) &&
8453 (last->op_private & OPpCONST_STRICT) &&
8454 (oa = first->op_sibling) && /* The fh. */
8455 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 8456 (oa->op_type == OP_CONST) &&
3b82e551 8457 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 8458 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 8459 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8460 (last == oa->op_sibling)) /* The bareword. */
8461 last->op_private &= ~OPpCONST_STRICT;
8462 }
16fe6d59
GS		 8463 return ck_fun(o);
8464}
8465
8466OP *
cea2e8a9 8467Perl_ck_repeat(pTHX_ OP *o)
79072805 8468{
7918f24d
NC		 8469 PERL_ARGS_ASSERT_CK_REPEAT;
8470
11343788
MB		 8471 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8472 o->op_private |= OPpREPEAT_DOLIST;
8473 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 8474 }
8475 else
11343788
MB		 8476 scalar(o);
8477 return o;
79072805
LW		 8478}
8479
8480OP *
cea2e8a9 8481Perl_ck_require(pTHX_ OP *o)
8990e307 8482{
97aff369 8483 dVAR;
a0714e2c 8484 GV* gv = NULL;
ec4ab249 8485
7918f24d
NC		 8486 PERL_ARGS_ASSERT_CK_REQUIRE;
8487
11343788 8488 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 8489 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 8490
8491 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 8492 SV * const sv = kid->op_sv;
5c144d81 8493 U32 was_readonly = SvREADONLY(sv);
8990e307 8494 char *s;
cfff9797
NC		 8495 STRLEN len;
8496 const char *end;
5c144d81
NC		 8497
8498 if (was_readonly) {
8499 if (SvFAKE(sv)) {
8500 sv_force_normal_flags(sv, 0);
8501 assert(!SvREADONLY(sv));
8502 was_readonly = 0;
8503 } else {
8504 SvREADONLY_off(sv);
8505 }
8506 }
8507
cfff9797
NC		 8508 s = SvPVX(sv);
8509 len = SvCUR(sv);
8510 end = s + len;
8511 for (; s < end; s++) {
a0d0e21e
LW		 8512 if (*s == ':' && s[1] == ':') {
8513 *s = '/';
5c6b2528 8514 Move(s+2, s+1, end - s - 1, char);
cfff9797 8515 --end;
a0d0e21e 8516 }
8990e307 8517 }
cfff9797 8518 SvEND_set(sv, end);
396482e1 8519 sv_catpvs(sv, ".pm");
5c144d81 8520 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 8521 }
8522 }
ec4ab249 8523
a72a1c8b
RGS		 8524 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8525 /* handle override, if any */
fafc274c 8526 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 8527 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 8528 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 8529 gv = gvp ? *gvp : NULL;
d6a985f2 8530 }
a72a1c8b 8531 }
ec4ab249 8532
b9f751c0 8533 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 8534 OP * const kid = cUNOPo->op_first;
f11453cb
NC		 8535 OP * newop;
8536
ec4ab249 8537 cUNOPo->op_first = 0;
f11453cb 8538#ifndef PERL_MAD
ec4ab249 8539 op_free(o);
eb8433b7 8540#endif
f11453cb 8541 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2fcb4757 8542 op_append_elem(OP_LIST, kid,
f11453cb
NC		 8543 scalar(newUNOP(OP_RV2CV, 0,
8544 newGVOP(OP_GV, 0,
8545 gv))))));
8546 op_getmad(o,newop,'O');
eb8433b7 8547 return newop;
ec4ab249
GA		 8548 }
8549
021f53de 8550 return scalar(ck_fun(o));
8990e307
LW		 8551}
8552
78f9721b
SM		 8553OP *
8554Perl_ck_return(pTHX_ OP *o)
8555{
97aff369 8556 dVAR;
e91684bf 8557 OP *kid;
7918f24d
NC		 8558
8559 PERL_ARGS_ASSERT_CK_RETURN;
8560
e91684bf 8561 kid = cLISTOPo->op_first->op_sibling;
78f9721b 8562 if (CvLVALUE(PL_compcv)) {
e91684bf 8563 for (; kid; kid = kid->op_sibling)
3ad73efd 8564 op_lvalue(kid, OP_LEAVESUBLV);
78f9721b 8565 }
e91684bf 8566
78f9721b
SM		 8567 return o;
8568}
8569
79072805 8570OP *
cea2e8a9 8571Perl_ck_select(pTHX_ OP *o)
79072805 8572{
27da23d5 8573 dVAR;
c07a80fd 8574 OP* kid;
7918f24d
NC		 8575
8576 PERL_ARGS_ASSERT_CK_SELECT;
8577
11343788
MB		 8578 if (o->op_flags & OPf_KIDS) {
8579 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 8580 if (kid && kid->op_sibling) {
11343788 8581 o->op_type = OP_SSELECT;
22c35a8c 8582 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788 8583 o = ck_fun(o);
985b9e54 8584 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 8585 }
8586 }
11343788
MB		 8587 o = ck_fun(o);
8588 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 8589 if (kid && kid->op_type == OP_RV2GV)
8590 kid->op_private &= ~HINT_STRICT_REFS;
11343788 8591 return o;
79072805
LW		 8592}
8593
8594OP *
cea2e8a9 8595Perl_ck_shift(pTHX_ OP *o)
79072805 8596{
97aff369 8597 dVAR;
6867be6d 8598 const I32 type = o->op_type;
79072805 8599
7918f24d
NC		 8600 PERL_ARGS_ASSERT_CK_SHIFT;
8601
11343788 8602 if (!(o->op_flags & OPf_KIDS)) {
538f5756
RZ		 8603 OP *argop;
8604
8605 if (!CvUNIQUE(PL_compcv)) {
8606 o->op_flags |= OPf_SPECIAL;
8607 return o;
8608 }
8609
8610 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
eb8433b7 8611#ifdef PERL_MAD
790427a5
DM		 8612 {
8613 OP * const oldo = o;
8614 o = newUNOP(type, 0, scalar(argop));
8615 op_getmad(oldo,o,'O');
8616 return o;
8617 }
eb8433b7 8618#else
821005df 8619 op_free(o);
6d4ff0d2 8620 return newUNOP(type, 0, scalar(argop));
eb8433b7 8621#endif
79072805 8622 }
d4fc4415 8623 return scalar(ck_fun(o));
79072805
LW		 8624}
8625
8626OP *
cea2e8a9 8627Perl_ck_sort(pTHX_ OP *o)
79072805 8628{
97aff369 8629 dVAR;
8e3f9bdf 8630 OP *firstkid;
bbce6d69 8631
7918f24d
NC		 8632 PERL_ARGS_ASSERT_CK_SORT;
8633
1496a290 8634 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
a4fc7abc 8635 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 8636 if (hinthv) {
a4fc7abc 8637 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 8638 if (svp) {
a4fc7abc 8639 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 8640 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8641 o->op_private |= OPpSORT_QSORT;
8642 if ((sorthints & HINT_SORT_STABLE) != 0)
8643 o->op_private |= OPpSORT_STABLE;
8644 }
8645 }
8646 }
8647
9ea6e965 8648 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 8649 simplify_sort(o);
8e3f9bdf
GS		 8650 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8651 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 8652 OP *k = NULL;
8e3f9bdf 8653 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 8654
463ee0b2 8655 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5983a79d 8656 LINKLIST(kid);
463ee0b2
LW		 8657 if (kid->op_type == OP_SCOPE) {
8658 k = kid->op_next;
8659 kid->op_next = 0;
79072805 8660 }
463ee0b2 8661 else if (kid->op_type == OP_LEAVE) {
11343788 8662 if (o->op_type == OP_SORT) {
93c66552 8663 op_null(kid); /* wipe out leave */
748a9306 8664 kid->op_next = kid;
463ee0b2 8665
748a9306
LW		 8666 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8667 if (k->op_next == kid)
8668 k->op_next = 0;
71a29c3c
GS		 8669 /* don't descend into loops */
8670 else if (k->op_type == OP_ENTERLOOP
8671 || k->op_type == OP_ENTERITER)
8672 {
8673 k = cLOOPx(k)->op_lastop;
8674 }
748a9306 8675 }
463ee0b2 8676 }
748a9306
LW		 8677 else
8678 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 8679 k = kLISTOP->op_first;
463ee0b2 8680 }
a2efc822 8681 CALL_PEEP(k);
a0d0e21e 8682
8e3f9bdf
GS		 8683 kid = firstkid;
8684 if (o->op_type == OP_SORT) {
8685 /* provide scalar context for comparison function/block */
8686 kid = scalar(kid);
a0d0e21e 8687 kid->op_next = kid;
8e3f9bdf 8688 }
a0d0e21e
LW		 8689 else
8690 kid->op_next = k;
11343788 8691 o->op_flags |= OPf_SPECIAL;
79072805 8692 }
c6e96bcb 8693 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 8694 op_null(firstkid);
8e3f9bdf
GS		 8695
8696 firstkid = firstkid->op_sibling;
79072805 8697 }
bbce6d69 8698
8e3f9bdf
GS		 8699 /* provide list context for arguments */
8700 if (o->op_type == OP_SORT)
8701 list(firstkid);
8702
11343788 8703 return o;
79072805 8704}
bda4119b
GS		 8705
8706STATIC void
cea2e8a9 8707S_simplify_sort(pTHX_ OP *o)
9c007264 8708{
97aff369 8709 dVAR;
9c007264
JH		 8710 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8711 OP *k;
eb209983 8712 int descending;
350de78d 8713 GV *gv;
770526c1 8714 const char *gvname;
7918f24d
NC		 8715
8716 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8717
9c007264
JH		 8718 if (!(o->op_flags & OPf_STACKED))
8719 return;
fafc274c
NC		 8720 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8721 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 8722 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 8723 if (kid->op_type != OP_SCOPE)
8724 return;
8725 kid = kLISTOP->op_last; /* get past scope */
8726 switch(kid->op_type) {
8727 case OP_NCMP:
8728 case OP_I_NCMP:
8729 case OP_SCMP:
8730 break;
8731 default:
8732 return;
8733 }
8734 k = kid; /* remember this node*/
8735 if (kBINOP->op_first->op_type != OP_RV2SV)
8736 return;
8737 kid = kBINOP->op_first; /* get past cmp */
8738 if (kUNOP->op_first->op_type != OP_GV)
8739 return;
8740 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 8741 gv = kGVOP_gv;
350de78d 8742 if (GvSTASH(gv) != PL_curstash)
9c007264 8743 return;
770526c1
NC		 8744 gvname = GvNAME(gv);
8745 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 8746 descending = 0;
770526c1 8747 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 8748 descending = 1;
9c007264
JH		 8749 else
8750 return;
eb209983 8751
9c007264
JH		 8752 kid = k; /* back to cmp */
8753 if (kBINOP->op_last->op_type != OP_RV2SV)
8754 return;
8755 kid = kBINOP->op_last; /* down to 2nd arg */
8756 if (kUNOP->op_first->op_type != OP_GV)
8757 return;
8758 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 8759 gv = kGVOP_gv;
770526c1
NC		 8760 if (GvSTASH(gv) != PL_curstash)
8761 return;
8762 gvname = GvNAME(gv);
8763 if ( descending
8764 ? !(*gvname == 'a' && gvname[1] == '\0')
8765 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 8766 return;
8767 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 8768 if (descending)
8769 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 8770 if (k->op_type == OP_NCMP)
8771 o->op_private |= OPpSORT_NUMERIC;
8772 if (k->op_type == OP_I_NCMP)
8773 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 8774 kid = cLISTOPo->op_first->op_sibling;
8775 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 8776#ifdef PERL_MAD
8777 op_getmad(kid,o,'S'); /* then delete it */
8778#else
e507f050 8779 op_free(kid); /* then delete it */
eb8433b7 8780#endif
9c007264 8781}
79072805
LW		 8782
8783OP *
cea2e8a9 8784Perl_ck_split(pTHX_ OP *o)
79072805 8785{
27da23d5 8786 dVAR;
79072805 8787 register OP *kid;
aeea060c 8788
7918f24d
NC		 8789 PERL_ARGS_ASSERT_CK_SPLIT;
8790
11343788
MB		 8791 if (o->op_flags & OPf_STACKED)
8792 return no_fh_allowed(o);
79072805 8793
11343788 8794 kid = cLISTOPo->op_first;
8990e307 8795 if (kid->op_type != OP_NULL)
cea2e8a9 8796 Perl_croak(aTHX_ "panic: ck_split");
8990e307 8797 kid = kid->op_sibling;
11343788 8798 op_free(cLISTOPo->op_first);
f126b75f
MW		 8799 if (kid)
8800 cLISTOPo->op_first = kid;
8801 else {
396482e1 8802 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 8803 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 8804 }
79072805 8805
de4bf5b3 8806 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 8807 OP * const sibl = kid->op_sibling;
463ee0b2 8808 kid->op_sibling = 0;
131b3ad0 8809 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 8810 if (cLISTOPo->op_first == cLISTOPo->op_last)
8811 cLISTOPo->op_last = kid;
8812 cLISTOPo->op_first = kid;
79072805
LW		 8813 kid->op_sibling = sibl;
8814 }
8815
8816 kid->op_type = OP_PUSHRE;
22c35a8c 8817 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 8818 scalar(kid);
a2a5de95
NC		 8819 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8820 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8821 "Use of /g modifier is meaningless in split");
f34840d8 8822 }
79072805
LW		 8823
8824 if (!kid->op_sibling)
2fcb4757 8825 op_append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 8826
8827 kid = kid->op_sibling;
8828 scalar(kid);
8829
8830 if (!kid->op_sibling)
2fcb4757 8831 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
ce3e5c45 8832 assert(kid->op_sibling);
79072805
LW		 8833
8834 kid = kid->op_sibling;
8835 scalar(kid);
8836
8837 if (kid->op_sibling)
53e06cf0 8838 return too_many_arguments(o,OP_DESC(o));
79072805 8839
11343788 8840 return o;
79072805
LW		 8841}
8842
8843OP *
1c846c1f 8844Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 8845{
551405c4 8846 const OP * const kid = cLISTOPo->op_first->op_sibling;
7918f24d
NC		 8847
8848 PERL_ARGS_ASSERT_CK_JOIN;
8849
041457d9
DM		 8850 if (kid && kid->op_type == OP_MATCH) {
8851 if (ckWARN(WARN_SYNTAX)) {
6867be6d 8852 const REGEXP *re = PM_GETRE(kPMOP);
d2c6dc5e 8853 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
220fc49f 8854 const STRLEN len = re ? RX_PRELEN(re) : 6;
9014280d 8855 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
bcdf7404 8856 "/%.*s/ should probably be written as \"%.*s\"",
d83b45b8 8857 (int)len, pmstr, (int)len, pmstr);
eb6e2d6f
GS		 8858 }
8859 }
8860 return ck_fun(o);
8861}
8862
d9088386
Z		 8863/*
8864=for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8865
8866Examines an op, which is expected to identify a subroutine at runtime,
8867and attempts to determine at compile time which subroutine it identifies.
8868This is normally used during Perl compilation to determine whether
8869a prototype can be applied to a function call. I<cvop> is the op
8870being considered, normally an C<rv2cv> op. A pointer to the identified
8871subroutine is returned, if it could be determined statically, and a null
8872pointer is returned if it was not possible to determine statically.
8873
8874Currently, the subroutine can be identified statically if the RV that the
8875C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8876A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8877suitable if the constant value must be an RV pointing to a CV. Details of
8878this process may change in future versions of Perl. If the C<rv2cv> op
8879has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8880the subroutine statically: this flag is used to suppress compile-time
8881magic on a subroutine call, forcing it to use default runtime behaviour.
8882
8883If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8884of a GV reference is modified. If a GV was examined and its CV slot was
8885found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8886If the op is not optimised away, and the CV slot is later populated with
8887a subroutine having a prototype, that flag eventually triggers the warning
8888"called too early to check prototype".
8889
8890If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8891of returning a pointer to the subroutine it returns a pointer to the
8892GV giving the most appropriate name for the subroutine in this context.
8893Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8894(C<CvANON>) subroutine that is referenced through a GV it will be the
8895referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8896A null pointer is returned as usual if there is no statically-determinable
8897subroutine.
7918f24d 8898
d9088386
Z		 8899=cut
8900*/
9d88f058 8901
d9088386
Z		 8902CV *
8903Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8904{
8905 OP *rvop;
8906 CV *cv;
8907 GV *gv;
8908 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8909 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8910 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8911 if (cvop->op_type != OP_RV2CV)
8912 return NULL;
8913 if (cvop->op_private & OPpENTERSUB_AMPER)
8914 return NULL;
8915 if (!(cvop->op_flags & OPf_KIDS))
8916 return NULL;
8917 rvop = cUNOPx(cvop)->op_first;
8918 switch (rvop->op_type) {
8919 case OP_GV: {
8920 gv = cGVOPx_gv(rvop);
8921 cv = GvCVu(gv);
8922 if (!cv) {
8923 if (flags & RV2CVOPCV_MARK_EARLY)
8924 rvop->op_private |= OPpEARLY_CV;
8925 return NULL;
46fc3d4c 8926 }
d9088386
Z		 8927 } break;
8928 case OP_CONST: {
8929 SV *rv = cSVOPx_sv(rvop);
8930 if (!SvROK(rv))
8931 return NULL;
8932 cv = (CV*)SvRV(rv);
8933 gv = NULL;
8934 } break;
8935 default: {
8936 return NULL;
8937 } break;
4633a7c4 8938 }
d9088386
Z		 8939 if (SvTYPE((SV*)cv) != SVt_PVCV)
8940 return NULL;
8941 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8942 if (!CvANON(cv) || !gv)
8943 gv = CvGV(cv);
8944 return (CV*)gv;
8945 } else {
8946 return cv;
7a52d87a 8947 }
d9088386 8948}
9d88f058 8949
d9088386
Z		 8950/*
8951=for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
824afba1 8952
d9088386
Z		 8953Performs the default fixup of the arguments part of an C<entersub>
8954op tree. This consists of applying list context to each of the
8955argument ops. This is the standard treatment used on a call marked
8956with C<&>, or a method call, or a call through a subroutine reference,
8957or any other call where the callee can't be identified at compile time,
8958or a call where the callee has no prototype.
824afba1 8959
d9088386
Z		 8960=cut
8961*/
340458b5 8962
d9088386
Z		 8963OP *
8964Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8965{
8966 OP *aop;
8967 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8968 aop = cUNOPx(entersubop)->op_first;
8969 if (!aop->op_sibling)
8970 aop = cUNOPx(aop)->op_first;
8971 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8972 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8973 list(aop);
3ad73efd 8974 op_lvalue(aop, OP_ENTERSUB);
d9088386
Z		 8975 }
8976 }
8977 return entersubop;
8978}
340458b5 8979
d9088386
Z		 8980/*
8981=for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8982
8983Performs the fixup of the arguments part of an C<entersub> op tree
8984based on a subroutine prototype. This makes various modifications to
8985the argument ops, from applying context up to inserting C<refgen> ops,
8986and checking the number and syntactic types of arguments, as directed by
8987the prototype. This is the standard treatment used on a subroutine call,
8988not marked with C<&>, where the callee can be identified at compile time
8989and has a prototype.
8990
8991I<protosv> supplies the subroutine prototype to be applied to the call.
8992It may be a normal defined scalar, of which the string value will be used.
8993Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8994that has been cast to C<SV*>) which has a prototype. The prototype
8995supplied, in whichever form, does not need to match the actual callee
8996referenced by the op tree.
8997
8998If the argument ops disagree with the prototype, for example by having
8999an unacceptable number of arguments, a valid op tree is returned anyway.
9000The error is reflected in the parser state, normally resulting in a single
9001exception at the top level of parsing which covers all the compilation
9002errors that occurred. In the error message, the callee is referred to
9003by the name defined by the I<namegv> parameter.
cbf82dd0 9004
d9088386
Z		 9005=cut
9006*/
9007
9008OP *
9009Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9010{
9011 STRLEN proto_len;
9012 const char *proto, *proto_end;
9013 OP *aop, *prev, *cvop;
9014 int optional = 0;
9015 I32 arg = 0;
9016 I32 contextclass = 0;
9017 const char *e = NULL;
9018 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9019 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9020 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8fa6a409
FC		 9021 if (SvTYPE(protosv) == SVt_PVCV)
9022 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9023 else proto = SvPV(protosv, proto_len);
d9088386
Z		 9024 proto_end = proto + proto_len;
9025 aop = cUNOPx(entersubop)->op_first;
9026 if (!aop->op_sibling)
9027 aop = cUNOPx(aop)->op_first;
9028 prev = aop;
9029 aop = aop->op_sibling;
9030 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9031 while (aop != cvop) {
9032 OP* o3;
9033 if (PL_madskills && aop->op_type == OP_STUB) {
9034 aop = aop->op_sibling;
9035 continue;
9036 }
9037 if (PL_madskills && aop->op_type == OP_NULL)
9038 o3 = ((UNOP*)aop)->op_first;
9039 else
9040 o3 = aop;
9041
9042 if (proto >= proto_end)
9043 return too_many_arguments(entersubop, gv_ename(namegv));
9044
9045 switch (*proto) {
597dcb2b
DG		 9046 case ';':
9047 optional = 1;
9048 proto++;
9049 continue;
9050 case '_':
9051 /* _ must be at the end */
9052 if (proto[1] && proto[1] != ';')
9053 goto oops;
9054 case '$':
9055 proto++;
9056 arg++;
9057 scalar(aop);
9058 break;
9059 case '%':
9060 case '@':
9061 list(aop);
9062 arg++;
9063 break;
9064 case '&':
9065 proto++;
9066 arg++;
9067 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9068 bad_type(arg,
9069 arg == 1 ? "block or sub {}" : "sub {}",
9070 gv_ename(namegv), o3);
9071 break;
9072 case '*':
9073 /* '*' allows any scalar type, including bareword */
9074 proto++;
9075 arg++;
9076 if (o3->op_type == OP_RV2GV)
9077 goto wrapref; /* autoconvert GLOB -> GLOBref */
9078 else if (o3->op_type == OP_CONST)
9079 o3->op_private &= ~OPpCONST_STRICT;
9080 else if (o3->op_type == OP_ENTERSUB) {
9081 /* accidental subroutine, revert to bareword */
9082 OP *gvop = ((UNOP*)o3)->op_first;
9083 if (gvop && gvop->op_type == OP_NULL) {
9084 gvop = ((UNOP*)gvop)->op_first;
9085 if (gvop) {
9086 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9087 ;
9088 if (gvop &&
9089 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9090 (gvop = ((UNOP*)gvop)->op_first) &&
9091 gvop->op_type == OP_GV)
9092 {
9093 GV * const gv = cGVOPx_gv(gvop);
9094 OP * const sibling = aop->op_sibling;
9095 SV * const n = newSVpvs("");
eb8433b7 9096#ifdef PERL_MAD
597dcb2b 9097 OP * const oldaop = aop;
eb8433b7 9098#else
597dcb2b 9099 op_free(aop);
eb8433b7 9100#endif
597dcb2b
DG		 9101 gv_fullname4(n, gv, "", FALSE);
9102 aop = newSVOP(OP_CONST, 0, n);
9103 op_getmad(oldaop,aop,'O');
9104 prev->op_sibling = aop;
9105 aop->op_sibling = sibling;
9106 }
9675f7ac
GS		 9107 }
9108 }
9109 }
597dcb2b 9110 scalar(aop);
c035a075
DG		 9111 break;
9112 case '+':
9113 proto++;
9114 arg++;
9115 if (o3->op_type == OP_RV2AV ||
9116 o3->op_type == OP_PADAV ||
9117 o3->op_type == OP_RV2HV ||
9118 o3->op_type == OP_PADHV
9119 ) {
9120 goto wrapref;
9121 }
9122 scalar(aop);
d9088386 9123 break;
597dcb2b
DG		 9124 case '[': case ']':
9125 goto oops;
d9088386 9126 break;
597dcb2b
DG		 9127 case '\\':
9128 proto++;
9129 arg++;
9130 again:
9131 switch (*proto++) {
9132 case '[':
9133 if (contextclass++ == 0) {
9134 e = strchr(proto, ']');
9135 if (!e || e == proto)
9136 goto oops;
9137 }
9138 else
9139 goto oops;
9140 goto again;
9141 break;
9142 case ']':
9143 if (contextclass) {
9144 const char *p = proto;
9145 const char *const end = proto;
9146 contextclass = 0;
062678b2
FC		 9147 while (*--p != '[')
9148 /* \[$] accepts any scalar lvalue */
9149 if (*p == '$'
9150 && Perl_op_lvalue_flags(aTHX_
9151 scalar(o3),
9152 OP_READ, /* not entersub */
9153 OP_LVALUE_NO_CROAK
9154 )) goto wrapref;
597dcb2b
DG		 9155 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
9156 (int)(end - p), p),
9157 gv_ename(namegv), o3);
9158 } else
9159 goto oops;
9160 break;
9161 case '*':
9162 if (o3->op_type == OP_RV2GV)
9163 goto wrapref;
9164 if (!contextclass)
9165 bad_type(arg, "symbol", gv_ename(namegv), o3);
9166 break;
9167 case '&':
9168 if (o3->op_type == OP_ENTERSUB)
9169 goto wrapref;
9170 if (!contextclass)
9171 bad_type(arg, "subroutine entry", gv_ename(namegv),
9172 o3);
9173 break;
9174 case '$':
9175 if (o3->op_type == OP_RV2SV ||
9176 o3->op_type == OP_PADSV ||
9177 o3->op_type == OP_HELEM ||
9178 o3->op_type == OP_AELEM)
9179 goto wrapref;
062678b2
FC		 9180 if (!contextclass) {
9181 /* \$ accepts any scalar lvalue */
9182 if (Perl_op_lvalue_flags(aTHX_
9183 scalar(o3),
9184 OP_READ, /* not entersub */
9185 OP_LVALUE_NO_CROAK
9186 )) goto wrapref;
597dcb2b 9187 bad_type(arg, "scalar", gv_ename(namegv), o3);
062678b2 9188 }
597dcb2b
DG		 9189 break;
9190 case '@':
9191 if (o3->op_type == OP_RV2AV ||
9192 o3->op_type == OP_PADAV)
9193 goto wrapref;
9194 if (!contextclass)
9195 bad_type(arg, "array", gv_ename(namegv), o3);
9196 break;
9197 case '%':
9198 if (o3->op_type == OP_RV2HV ||
9199 o3->op_type == OP_PADHV)
9200 goto wrapref;
9201 if (!contextclass)
9202 bad_type(arg, "hash", gv_ename(namegv), o3);
9203 break;
9204 wrapref:
9205 {
9206 OP* const kid = aop;
9207 OP* const sib = kid->op_sibling;
9208 kid->op_sibling = 0;
9209 aop = newUNOP(OP_REFGEN, 0, kid);
9210 aop->op_sibling = sib;
9211 prev->op_sibling = aop;
9212 }
9213 if (contextclass && e) {
9214 proto = e + 1;
9215 contextclass = 0;
9216 }
9217 break;
9218 default: goto oops;
4633a7c4 9219 }
597dcb2b
DG		 9220 if (contextclass)
9221 goto again;
4633a7c4 9222 break;
597dcb2b
DG		 9223 case ' ':
9224 proto++;
9225 continue;
9226 default:
108f32a5
BF		 9227 oops: {
9228 SV* const tmpsv = sv_newmortal();
9229 gv_efullname3(tmpsv, namegv, NULL);
9230 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9231 SVfARG(tmpsv), SVfARG(protosv));
9232 }
d9088386
Z		 9233 }
9234
3ad73efd 9235 op_lvalue(aop, OP_ENTERSUB);
d9088386
Z		 9236 prev = aop;
9237 aop = aop->op_sibling;
9238 }
9239 if (aop == cvop && *proto == '_') {
9240 /* generate an access to $_ */
9241 aop = newDEFSVOP();
9242 aop->op_sibling = prev->op_sibling;
9243 prev->op_sibling = aop; /* instead of cvop */
9244 }
9245 if (!optional && proto_end > proto &&
9246 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9247 return too_few_arguments(entersubop, gv_ename(namegv));
9248 return entersubop;
9249}
9250
9251/*
9252=for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9253
9254Performs the fixup of the arguments part of an C<entersub> op tree either
9255based on a subroutine prototype or using default list-context processing.
9256This is the standard treatment used on a subroutine call, not marked
9257with C<&>, where the callee can be identified at compile time.
9258
9259I<protosv> supplies the subroutine prototype to be applied to the call,
9260or indicates that there is no prototype. It may be a normal scalar,
9261in which case if it is defined then the string value will be used
9262as a prototype, and if it is undefined then there is no prototype.
9263Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9264that has been cast to C<SV*>), of which the prototype will be used if it
9265has one. The prototype (or lack thereof) supplied, in whichever form,
9266does not need to match the actual callee referenced by the op tree.
9267
9268If the argument ops disagree with the prototype, for example by having
9269an unacceptable number of arguments, a valid op tree is returned anyway.
9270The error is reflected in the parser state, normally resulting in a single
9271exception at the top level of parsing which covers all the compilation
9272errors that occurred. In the error message, the callee is referred to
9273by the name defined by the I<namegv> parameter.
9274
9275=cut
9276*/
9277
9278OP *
9279Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9280 GV *namegv, SV *protosv)
9281{
9282 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9283 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9284 return ck_entersub_args_proto(entersubop, namegv, protosv);
9285 else
9286 return ck_entersub_args_list(entersubop);
9287}
9288
4aaa4757
FC		 9289OP *
9290Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9291{
9292 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9293 OP *aop = cUNOPx(entersubop)->op_first;
9294
9295 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9296
9297 if (!opnum) {
14f0f125 9298 OP *cvop;
4aaa4757
FC		 9299 if (!aop->op_sibling)
9300 aop = cUNOPx(aop)->op_first;
4aaa4757
FC		 9301 aop = aop->op_sibling;
9302 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9303 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9304 aop = aop->op_sibling;
9305 continue;
9306 }
9307 if (aop != cvop)
9308 (void)too_many_arguments(entersubop, GvNAME(namegv));
9309
9310 op_free(entersubop);
9311 switch(GvNAME(namegv)[2]) {
9312 case 'F': return newSVOP(OP_CONST, 0,
9313 newSVpv(CopFILE(PL_curcop),0));
9314 case 'L': return newSVOP(
9315 OP_CONST, 0,
9316 Perl_newSVpvf(aTHX_
9317 "%"IVdf, (IV)CopLINE(PL_curcop)
9318 )
9319 );
9320 case 'P': return newSVOP(OP_CONST, 0,
9321 (PL_curstash
9322 ? newSVhek(HvNAME_HEK(PL_curstash))
9323 : &PL_sv_undef
9324 )
9325 );
9326 }
9327 assert(0);
9328 }
9329 else {
9330 OP *prev, *cvop;
9331 U32 paren;
9332#ifdef PERL_MAD
9333 bool seenarg = FALSE;
9334#endif
9335 if (!aop->op_sibling)
9336 aop = cUNOPx(aop)->op_first;
9337
9338 prev = aop;
9339 aop = aop->op_sibling;
9340 prev->op_sibling = NULL;
9341 for (cvop = aop;
9342 cvop->op_sibling;
9343 prev=cvop, cvop = cvop->op_sibling)
9344#ifdef PERL_MAD
9345 if (PL_madskills && cvop->op_sibling
9346 && cvop->op_type != OP_STUB) seenarg = TRUE
9347#endif
9348 ;
9349 prev->op_sibling = NULL;
9350 paren = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9351 op_free(cvop);
9352 if (aop == cvop) aop = NULL;
9353 op_free(entersubop);
9354
9355 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9356 case OA_UNOP:
9357 case OA_BASEOP_OR_UNOP:
9358 case OA_FILESTATOP:
9359 return aop ? newUNOP(opnum,paren,aop) : newOP(opnum,paren);
9360 case OA_BASEOP:
9361 if (aop) {
9362#ifdef PERL_MAD
9363 if (!PL_madskills || seenarg)
9364#endif
9365 (void)too_many_arguments(aop, GvNAME(namegv));
9366 op_free(aop);
9367 }
9368 return newOP(opnum,0);
9369 default:
9370 return convert(opnum,0,aop);
9371 }
9372 }
9373 assert(0);
9374 return entersubop;
9375}
9376
d9088386
Z		 9377/*
9378=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9379
9380Retrieves the function that will be used to fix up a call to I<cv>.
9381Specifically, the function is applied to an C<entersub> op tree for a
9382subroutine call, not marked with C<&>, where the callee can be identified
9383at compile time as I<cv>.
9384
9385The C-level function pointer is returned in I<*ckfun_p>, and an SV
9386argument for it is returned in I<*ckobj_p>. The function is intended
9387to be called in this manner:
9388
9389 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9390
9391In this call, I<entersubop> is a pointer to the C<entersub> op,
9392which may be replaced by the check function, and I<namegv> is a GV
9393supplying the name that should be used by the check function to refer
9394to the callee of the C<entersub> op if it needs to emit any diagnostics.
9395It is permitted to apply the check function in non-standard situations,
9396such as to a call to a different subroutine or to a method call.
340458b5 9397
d9088386
Z		 9398By default, the function is
9399L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9400and the SV parameter is I<cv> itself. This implements standard
9401prototype processing. It can be changed, for a particular subroutine,
9402by L</cv_set_call_checker>.
74735042 9403
d9088386
Z		 9404=cut
9405*/
9406
9407void
9408Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9409{
9410 MAGIC *callmg;
9411 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9412 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9413 if (callmg) {
9414 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9415 *ckobj_p = callmg->mg_obj;
9416 } else {
9417 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9418 *ckobj_p = (SV*)cv;
9419 }
9420}
9421
9422/*
9423=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9424
9425Sets the function that will be used to fix up a call to I<cv>.
9426Specifically, the function is applied to an C<entersub> op tree for a
9427subroutine call, not marked with C<&>, where the callee can be identified
9428at compile time as I<cv>.
9429
9430The C-level function pointer is supplied in I<ckfun>, and an SV argument
9431for it is supplied in I<ckobj>. The function is intended to be called
9432in this manner:
9433
9434 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9435
9436In this call, I<entersubop> is a pointer to the C<entersub> op,
9437which may be replaced by the check function, and I<namegv> is a GV
9438supplying the name that should be used by the check function to refer
9439to the callee of the C<entersub> op if it needs to emit any diagnostics.
9440It is permitted to apply the check function in non-standard situations,
9441such as to a call to a different subroutine or to a method call.
9442
9443The current setting for a particular CV can be retrieved by
9444L</cv_get_call_checker>.
9445
9446=cut
9447*/
9448
9449void
9450Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9451{
9452 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9453 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9454 if (SvMAGICAL((SV*)cv))
9455 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9456 } else {
9457 MAGIC *callmg;
9458 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9459 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9460 if (callmg->mg_flags & MGf_REFCOUNTED) {
9461 SvREFCNT_dec(callmg->mg_obj);
9462 callmg->mg_flags &= ~MGf_REFCOUNTED;
9463 }
9464 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9465 callmg->mg_obj = ckobj;
9466 if (ckobj != (SV*)cv) {
9467 SvREFCNT_inc_simple_void_NN(ckobj);
9468 callmg->mg_flags |= MGf_REFCOUNTED;
74735042 9469 }
340458b5 9470 }
d9088386
Z		 9471}
9472
9473OP *
9474Perl_ck_subr(pTHX_ OP *o)
9475{
9476 OP *aop, *cvop;
9477 CV *cv;
9478 GV *namegv;
9479
9480 PERL_ARGS_ASSERT_CK_SUBR;
9481
9482 aop = cUNOPx(o)->op_first;
9483 if (!aop->op_sibling)
9484 aop = cUNOPx(aop)->op_first;
9485 aop = aop->op_sibling;
9486 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9487 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9488 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9489
767eda44 9490 o->op_private &= ~1;
d9088386
Z		 9491 o->op_private |= OPpENTERSUB_HASTARG;
9492 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9493 if (PERLDB_SUB && PL_curstash != PL_debstash)
9494 o->op_private |= OPpENTERSUB_DB;
9495 if (cvop->op_type == OP_RV2CV) {
9496 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9497 op_null(cvop);
9498 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9499 if (aop->op_type == OP_CONST)
9500 aop->op_private &= ~OPpCONST_STRICT;
9501 else if (aop->op_type == OP_LIST) {
9502 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9503 if (sib && sib->op_type == OP_CONST)
9504 sib->op_private &= ~OPpCONST_STRICT;
9505 }
9506 }
9507
9508 if (!cv) {
9509 return ck_entersub_args_list(o);
9510 } else {
9511 Perl_call_checker ckfun;
9512 SV *ckobj;
9513 cv_get_call_checker(cv, &ckfun, &ckobj);
9514 return ckfun(aTHX_ o, namegv, ckobj);
9515 }
79072805
LW		 9516}
9517
9518OP *
cea2e8a9 9519Perl_ck_svconst(pTHX_ OP *o)
8990e307 9520{
7918f24d 9521 PERL_ARGS_ASSERT_CK_SVCONST;
96a5add6 9522 PERL_UNUSED_CONTEXT;
11343788
MB		 9523 SvREADONLY_on(cSVOPo->op_sv);
9524 return o;
8990e307
LW		 9525}
9526
9527OP *
d4ac975e
GA		 9528Perl_ck_chdir(pTHX_ OP *o)
9529{
a4e74480 9530 PERL_ARGS_ASSERT_CK_CHDIR;
d4ac975e 9531 if (o->op_flags & OPf_KIDS) {
1496a290 9532 SVOP * const kid = (SVOP*)cUNOPo->op_first;
d4ac975e
GA		 9533
9534 if (kid && kid->op_type == OP_CONST &&
9535 (kid->op_private & OPpCONST_BARE))
9536 {
9537 o->op_flags |= OPf_SPECIAL;
9538 kid->op_private &= ~OPpCONST_STRICT;
9539 }
9540 }
9541 return ck_fun(o);
9542}
9543
9544OP *
cea2e8a9 9545Perl_ck_trunc(pTHX_ OP *o)
79072805 9546{
7918f24d
NC		 9547 PERL_ARGS_ASSERT_CK_TRUNC;
9548
11343788
MB		 9549 if (o->op_flags & OPf_KIDS) {
9550 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 9551
a0d0e21e
LW		 9552 if (kid->op_type == OP_NULL)
9553 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 9554 if (kid && kid->op_type == OP_CONST &&
9555 (kid->op_private & OPpCONST_BARE))
9556 {
11343788 9557 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 9558 kid->op_private &= ~OPpCONST_STRICT;
9559 }
79072805 9560 }
11343788 9561 return ck_fun(o);
79072805
LW		 9562}
9563
35fba0d9
RG		 9564OP *
9565Perl_ck_substr(pTHX_ OP *o)
9566{
7918f24d
NC		 9567 PERL_ARGS_ASSERT_CK_SUBSTR;
9568
35fba0d9 9569 o = ck_fun(o);
1d866c12 9570 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 9571 OP *kid = cLISTOPo->op_first;
9572
9573 if (kid->op_type == OP_NULL)
9574 kid = kid->op_sibling;
9575 if (kid)
9576 kid->op_flags |= OPf_MOD;
9577
9578 }
9579 return o;
9580}
9581
878d132a 9582OP *
cba5a3b0
DG		 9583Perl_ck_each(pTHX_ OP *o)
9584{
9585 dVAR;
9586 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9587 const unsigned orig_type = o->op_type;
9588 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9589 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9590 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9591 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9592
9593 PERL_ARGS_ASSERT_CK_EACH;
9594
9595 if (kid) {
9596 switch (kid->op_type) {
9597 case OP_PADHV:
9598 case OP_RV2HV:
9599 break;
9600 case OP_PADAV:
9601 case OP_RV2AV:
9602 CHANGE_TYPE(o, array_type);
9603 break;
9604 case OP_CONST:
7ac5715b
FC		 9605 if (kid->op_private == OPpCONST_BARE
9606 || !SvROK(cSVOPx_sv(kid))
9607 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9608 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9609 )
9610 /* we let ck_fun handle it */
cba5a3b0
DG		 9611 break;
9612 default:
9613 CHANGE_TYPE(o, ref_type);
7ac5715b 9614 scalar(kid);
cba5a3b0
DG		 9615 }
9616 }
9617 /* if treating as a reference, defer additional checks to runtime */
9618 return o->op_type == ref_type ? o : ck_fun(o);
9619}
9620
867fa1e2
YO		 9621/* caller is supposed to assign the return to the
9622 container of the rep_op var */
20381b50 9623STATIC OP *
867fa1e2 9624S_opt_scalarhv(pTHX_ OP *rep_op) {
749123ff 9625 dVAR;
867fa1e2
YO		 9626 UNOP *unop;
9627
9628 PERL_ARGS_ASSERT_OPT_SCALARHV;
9629
9630 NewOp(1101, unop, 1, UNOP);
9631 unop->op_type = (OPCODE)OP_BOOLKEYS;
9632 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9633 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9634 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9635 unop->op_first = rep_op;
9636 unop->op_next = rep_op->op_next;
9637 rep_op->op_next = (OP*)unop;
9638 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9639 unop->op_sibling = rep_op->op_sibling;
9640 rep_op->op_sibling = NULL;
9641 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9642 if (rep_op->op_type == OP_PADHV) {
9643 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9644 rep_op->op_flags |= OPf_WANT_LIST;
9645 }
9646 return (OP*)unop;
9647}
9648
540dd770
GG		 9649/* Check for in place reverse and sort assignments like "@a = reverse @a"
9650 and modify the optree to make them work inplace */
e52d58aa 9651
540dd770
GG		 9652STATIC void
9653S_inplace_aassign(pTHX_ OP *o) {
e52d58aa 9654
540dd770
GG		 9655 OP *modop, *modop_pushmark;
9656 OP *oright;
9657 OP *oleft, *oleft_pushmark;
e52d58aa 9658
540dd770 9659 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
e52d58aa 9660
540dd770 9661 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
e52d58aa 9662
540dd770
GG		 9663 assert(cUNOPo->op_first->op_type == OP_NULL);
9664 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
9665 assert(modop_pushmark->op_type == OP_PUSHMARK);
9666 modop = modop_pushmark->op_sibling;
e92f843d 9667
540dd770
GG		 9668 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
9669 return;
9670
9671 /* no other operation except sort/reverse */
9672 if (modop->op_sibling)
9673 return;
9674
9675 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
9676 oright = cUNOPx(modop)->op_first->op_sibling;
9677
9678 if (modop->op_flags & OPf_STACKED) {
9679 /* skip sort subroutine/block */
9680 assert(oright->op_type == OP_NULL);
9681 oright = oright->op_sibling;
9682 }
9683
9684 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
9685 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
9686 assert(oleft_pushmark->op_type == OP_PUSHMARK);
9687 oleft = oleft_pushmark->op_sibling;
9688
9689 /* Check the lhs is an array */
9690 if (!oleft ||
9691 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
9692 || oleft->op_sibling
9693 || (oleft->op_private & OPpLVAL_INTRO)
9694 )
9695 return;
9696
9697 /* Only one thing on the rhs */
9698 if (oright->op_sibling)
9699 return;
2f9e2db0
VP		 9700
9701 /* check the array is the same on both sides */
9702 if (oleft->op_type == OP_RV2AV) {
9703 if (oright->op_type != OP_RV2AV
9704 || !cUNOPx(oright)->op_first
9705 || cUNOPx(oright)->op_first->op_type != OP_GV
9706 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9707 cGVOPx_gv(cUNOPx(oright)->op_first)
9708 )
540dd770 9709 return;
2f9e2db0
VP		 9710 }
9711 else if (oright->op_type != OP_PADAV
9712 || oright->op_targ != oleft->op_targ
9713 )
540dd770
GG		 9714 return;
9715
9716 /* This actually is an inplace assignment */
e52d58aa 9717
540dd770
GG		 9718 modop->op_private |= OPpSORT_INPLACE;
9719
9720 /* transfer MODishness etc from LHS arg to RHS arg */
9721 oright->op_flags = oleft->op_flags;
9722
9723 /* remove the aassign op and the lhs */
9724 op_null(o);
9725 op_null(oleft_pushmark);
9726 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
9727 op_null(cUNOPx(oleft)->op_first);
9728 op_null(oleft);
2f9e2db0
VP		 9729}
9730
3c78429c
DM		 9731#define MAX_DEFERRED 4
9732
9733#define DEFER(o) \
9734 if (defer_ix == (MAX_DEFERRED-1)) { \
9735 CALL_RPEEP(defer_queue[defer_base]); \
9736 defer_base = (defer_base + 1) % MAX_DEFERRED; \
9737 defer_ix--; \
9738 } \
9739 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
9740
61b743bb
DM		 9741/* A peephole optimizer. We visit the ops in the order they're to execute.
9742 * See the comments at the top of this file for more details about when
9743 * peep() is called */
463ee0b2 9744
79072805 9745void
1a0a2ba9 9746Perl_rpeep(pTHX_ register OP *o)
79072805 9747{
27da23d5 9748 dVAR;
c445ea15 9749 register OP* oldop = NULL;
3c78429c
DM		 9750 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
9751 int defer_base = 0;
9752 int defer_ix = -1;
2d8e6c8d 9753
2814eb74 9754 if (!o || o->op_opt)
79072805 9755 return;
a0d0e21e 9756 ENTER;
462e5cf6 9757 SAVEOP();
7766f137 9758 SAVEVPTR(PL_curcop);
3c78429c
DM		 9759 for (;; o = o->op_next) {
9760 if (o && o->op_opt)
9761 o = NULL;
cd197e1e
VP		 9762 if (!o) {
9763 while (defer_ix >= 0)
9764 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
3c78429c 9765 break;
cd197e1e 9766 }
3c78429c 9767
6d7dd4a5
NC		 9768 /* By default, this op has now been optimised. A couple of cases below
9769 clear this again. */
9770 o->op_opt = 1;
533c011a 9771 PL_op = o;
a0d0e21e 9772 switch (o->op_type) {
a0d0e21e 9773 case OP_DBSTATE:
3280af22 9774 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e 9775 break;
ac56e7de
NC		 9776 case OP_NEXTSTATE:
9777 PL_curcop = ((COP*)o); /* for warnings */
9778
9779 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9780 to carry two labels. For now, take the easier option, and skip
9781 this optimisation if the first NEXTSTATE has a label. */
bcc76ee3 9782 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
ac56e7de
NC		 9783 OP *nextop = o->op_next;
9784 while (nextop && nextop->op_type == OP_NULL)
9785 nextop = nextop->op_next;
9786
9787 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9788 COP *firstcop = (COP *)o;
9789 COP *secondcop = (COP *)nextop;
9790 /* We want the COP pointed to by o (and anything else) to
9791 become the next COP down the line. */
9792 cop_free(firstcop);
9793
9794 firstcop->op_next = secondcop->op_next;
9795
9796 /* Now steal all its pointers, and duplicate the other
9797 data. */
9798 firstcop->cop_line = secondcop->cop_line;
9799#ifdef USE_ITHREADS
9800 firstcop->cop_stashpv = secondcop->cop_stashpv;
9801 firstcop->cop_file = secondcop->cop_file;
9802#else
9803 firstcop->cop_stash = secondcop->cop_stash;
9804 firstcop->cop_filegv = secondcop->cop_filegv;
9805#endif
9806 firstcop->cop_hints = secondcop->cop_hints;
9807 firstcop->cop_seq = secondcop->cop_seq;
9808 firstcop->cop_warnings = secondcop->cop_warnings;
9809 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9810
9811#ifdef USE_ITHREADS
9812 secondcop->cop_stashpv = NULL;
9813 secondcop->cop_file = NULL;
9814#else
9815 secondcop->cop_stash = NULL;
9816 secondcop->cop_filegv = NULL;
9817#endif
9818 secondcop->cop_warnings = NULL;
9819 secondcop->cop_hints_hash = NULL;
9820
9821 /* If we use op_null(), and hence leave an ex-COP, some
9822 warnings are misreported. For example, the compile-time
9823 error in 'use strict; no strict refs;' */
9824 secondcop->op_type = OP_NULL;
9825 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9826 }
9827 }
9828 break;
a0d0e21e 9829
df91b2c5
AE		 9830 case OP_CONCAT:
9831 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9832 if (o->op_next->op_private & OPpTARGET_MY) {
9833 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 9834 break; /* ignore_optimization */
df91b2c5
AE		 9835 else {
9836 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9837 o->op_targ = o->op_next->op_targ;
9838 o->op_next->op_targ = 0;
9839 o->op_private |= OPpTARGET_MY;
9840 }
9841 }
9842 op_null(o->op_next);
9843 }
df91b2c5 9844 break;
6d7dd4a5
NC		 9845 case OP_STUB:
9846 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9847 break; /* Scalar stub must produce undef. List stub is noop */
9848 }
9849 goto nothin;
79072805 9850 case OP_NULL:
acb36ea4 9851 if (o->op_targ == OP_NEXTSTATE
5edb5b2a 9852 || o->op_targ == OP_DBSTATE)
acb36ea4 9853 {
3280af22 9854 PL_curcop = ((COP*)o);
acb36ea4 9855 }
dad75012 9856 /* XXX: We avoid setting op_seq here to prevent later calls
1a0a2ba9 9857 to rpeep() from mistakenly concluding that optimisation
dad75012
AMS		 9858 has already occurred. This doesn't fix the real problem,
9859 though (See 20010220.007). AMS 20010719 */
2814eb74 9860 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 9861 o->op_opt = 0;
f46f2f82 9862 /* FALL THROUGH */
79072805 9863 case OP_SCALAR:
93a17b20 9864 case OP_LINESEQ:
463ee0b2 9865 case OP_SCOPE:
6d7dd4a5 9866 nothin:
a0d0e21e
LW		 9867 if (oldop && o->op_next) {
9868 oldop->op_next = o->op_next;
6d7dd4a5 9869 o->op_opt = 0;
79072805
LW		 9870 continue;
9871 }
79072805
LW		 9872 break;
9873
6a077020 9874 case OP_PADAV:
79072805 9875 case OP_GV:
6a077020 9876 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 9877 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 9878 o->op_next : o->op_next->op_next;
a0d0e21e 9879 IV i;
f9dc862f 9880 if (pop && pop->op_type == OP_CONST &&
af5acbb4 9881 ((PL_op = pop->op_next)) &&
8990e307 9882 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 9883 !(pop->op_next->op_private &
78f9721b 9884 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
e1dccc0d 9885 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
8990e307 9886 {
350de78d 9887 GV *gv;
af5acbb4
DM		 9888 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9889 no_bareword_allowed(pop);
6a077020
DM		 9890 if (o->op_type == OP_GV)
9891 op_null(o->op_next);
93c66552
DM		 9892 op_null(pop->op_next);
9893 op_null(pop);
a0d0e21e
LW		 9894 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9895 o->op_next = pop->op_next->op_next;
22c35a8c 9896 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 9897 o->op_private = (U8)i;
6a077020
DM		 9898 if (o->op_type == OP_GV) {
9899 gv = cGVOPo_gv;
9900 GvAVn(gv);
93bad3fd 9901 o->op_type = OP_AELEMFAST;
6a077020
DM		 9902 }
9903 else
93bad3fd 9904 o->op_type = OP_AELEMFAST_LEX;
6a077020 9905 }
6a077020
DM		 9906 break;
9907 }
9908
9909 if (o->op_next->op_type == OP_RV2SV) {
9910 if (!(o->op_next->op_private & OPpDEREF)) {
9911 op_null(o->op_next);
9912 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9913 | OPpOUR_INTRO);
9914 o->op_next = o->op_next->op_next;
9915 o->op_type = OP_GVSV;
9916 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 9917 }
79072805 9918 }
89de2904
AMS		 9919 else if (o->op_next->op_type == OP_READLINE
9920 && o->op_next->op_next->op_type == OP_CONCAT
9921 && (o->op_next->op_next->op_flags & OPf_STACKED))
9922 {
d2c45030
AMS		 9923 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9924 o->op_type = OP_RCATLINE;
9925 o->op_flags |= OPf_STACKED;
9926 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 9927 op_null(o->op_next->op_next);
d2c45030 9928 op_null(o->op_next);
89de2904 9929 }
76cd736e 9930
79072805 9931 break;
867fa1e2
YO		 9932
9933 {
9934 OP *fop;
9935 OP *sop;
9936
9937 case OP_NOT:
9938 fop = cUNOP->op_first;
9939 sop = NULL;
9940 goto stitch_keys;
9941 break;
9942
9943 case OP_AND:
79072805 9944 case OP_OR:
c963b151 9945 case OP_DOR:
867fa1e2
YO		 9946 fop = cLOGOP->op_first;
9947 sop = fop->op_sibling;
9948 while (cLOGOP->op_other->op_type == OP_NULL)
9949 cLOGOP->op_other = cLOGOP->op_other->op_next;
db4d68cf
DM		 9950 while (o->op_next && ( o->op_type == o->op_next->op_type
9951 || o->op_next->op_type == OP_NULL))
9952 o->op_next = o->op_next->op_next;
3c78429c 9953 DEFER(cLOGOP->op_other);
867fa1e2
YO		 9954
9955 stitch_keys:
9956 o->op_opt = 1;
9957 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9958 || ( sop &&
9959 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9960 )
9961 ){
9962 OP * nop = o;
9963 OP * lop = o;
aaf643ce 9964 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
867fa1e2
YO		 9965 while (nop && nop->op_next) {
9966 switch (nop->op_next->op_type) {
9967 case OP_NOT:
9968 case OP_AND:
9969 case OP_OR:
9970 case OP_DOR:
9971 lop = nop = nop->op_next;
9972 break;
9973 case OP_NULL:
9974 nop = nop->op_next;
9975 break;
9976 default:
9977 nop = NULL;
9978 break;
9979 }
9980 }
9981 }
aaf643ce 9982 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
867fa1e2
YO		 9983 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9984 cLOGOP->op_first = opt_scalarhv(fop);
9985 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9986 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9987 }
9988 }
9989
9990
9991 break;
9992 }
9993
9994 case OP_MAPWHILE:
9995 case OP_GREPWHILE:
2c2d71f5
JH		 9996 case OP_ANDASSIGN:
9997 case OP_ORASSIGN:
c963b151 9998 case OP_DORASSIGN:
1a67a97c
SM		 9999 case OP_COND_EXPR:
10000 case OP_RANGE:
c5917253 10001 case OP_ONCE:
fd4d1407
IZ		 10002 while (cLOGOP->op_other->op_type == OP_NULL)
10003 cLOGOP->op_other = cLOGOP->op_other->op_next;
3c78429c 10004 DEFER(cLOGOP->op_other);
79072805
LW		 10005 break;
10006
79072805 10007 case OP_ENTERLOOP:
9c2ca71a 10008 case OP_ENTERITER:
58cccf98
SM		 10009 while (cLOOP->op_redoop->op_type == OP_NULL)
10010 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
58cccf98
SM		 10011 while (cLOOP->op_nextop->op_type == OP_NULL)
10012 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
58cccf98
SM		 10013 while (cLOOP->op_lastop->op_type == OP_NULL)
10014 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
3c78429c
DM		 10015 /* a while(1) loop doesn't have an op_next that escapes the
10016 * loop, so we have to explicitly follow the op_lastop to
10017 * process the rest of the code */
10018 DEFER(cLOOP->op_lastop);
79072805
LW		 10019 break;
10020
79072805 10021 case OP_SUBST:
29f2e912
NC		 10022 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10023 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10024 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10025 cPMOP->op_pmstashstartu.op_pmreplstart
10026 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
3c78429c 10027 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 10028 break;
10029
fe1bc4cf 10030 case OP_SORT: {
fe1bc4cf 10031 /* check that RHS of sort is a single plain array */
551405c4 10032 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 10033 if (!oright || oright->op_type != OP_PUSHMARK)
10034 break;
471178c0 10035
540dd770
GG		 10036 if (o->op_private & OPpSORT_INPLACE)
10037 break;
10038
471178c0
NC		 10039 /* reverse sort ... can be optimised. */
10040 if (!cUNOPo->op_sibling) {
10041 /* Nothing follows us on the list. */
551405c4 10042 OP * const reverse = o->op_next;
471178c0
NC		 10043
10044 if (reverse->op_type == OP_REVERSE &&
10045 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 10046 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 10047 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10048 && (cUNOPx(pushmark)->op_sibling == o)) {
10049 /* reverse -> pushmark -> sort */
10050 o->op_private |= OPpSORT_REVERSE;
10051 op_null(reverse);
10052 pushmark->op_next = oright->op_next;
10053 op_null(oright);
10054 }
10055 }
10056 }
10057
fe1bc4cf
DM		 10058 break;
10059 }
ef3e5ea9
NC		 10060
10061 case OP_REVERSE: {
e682d7b7 10062 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 10063 OP *gvop = NULL;
ef3e5ea9 10064 LISTOP *enter, *exlist;
ef3e5ea9 10065
540dd770 10066 if (o->op_private & OPpSORT_INPLACE)
484c818f 10067 break;
484c818f 10068
ef3e5ea9
NC		 10069 enter = (LISTOP *) o->op_next;
10070 if (!enter)
10071 break;
10072 if (enter->op_type == OP_NULL) {
10073 enter = (LISTOP *) enter->op_next;
10074 if (!enter)
10075 break;
10076 }
d46f46af
NC		 10077 /* for $a (...) will have OP_GV then OP_RV2GV here.
10078 for (...) just has an OP_GV. */
ce335f37
NC		 10079 if (enter->op_type == OP_GV) {
10080 gvop = (OP *) enter;
10081 enter = (LISTOP *) enter->op_next;
10082 if (!enter)
10083 break;
d46f46af
NC		 10084 if (enter->op_type == OP_RV2GV) {
10085 enter = (LISTOP *) enter->op_next;
10086 if (!enter)
ce335f37 10087 break;
d46f46af 10088 }
ce335f37
NC		 10089 }
10090
ef3e5ea9
NC		 10091 if (enter->op_type != OP_ENTERITER)
10092 break;
10093
10094 iter = enter->op_next;
10095 if (!iter || iter->op_type != OP_ITER)
10096 break;
10097
ce335f37
NC		 10098 expushmark = enter->op_first;
10099 if (!expushmark || expushmark->op_type != OP_NULL
10100 || expushmark->op_targ != OP_PUSHMARK)
10101 break;
10102
10103 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 10104 if (!exlist || exlist->op_type != OP_NULL
10105 || exlist->op_targ != OP_LIST)
10106 break;
10107
10108 if (exlist->op_last != o) {
10109 /* Mmm. Was expecting to point back to this op. */
10110 break;
10111 }
10112 theirmark = exlist->op_first;
10113 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10114 break;
10115
c491ecac 10116 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 10117 /* There's something between the mark and the reverse, eg
10118 for (1, reverse (...))
10119 so no go. */
10120 break;
10121 }
10122
c491ecac
NC		 10123 ourmark = ((LISTOP *)o)->op_first;
10124 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10125 break;
10126
ef3e5ea9
NC		 10127 ourlast = ((LISTOP *)o)->op_last;
10128 if (!ourlast || ourlast->op_next != o)
10129 break;
10130
e682d7b7
NC		 10131 rv2av = ourmark->op_sibling;
10132 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10133 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10134 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10135 /* We're just reversing a single array. */
10136 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10137 enter->op_flags |= OPf_STACKED;
10138 }
10139
ef3e5ea9
NC		 10140 /* We don't have control over who points to theirmark, so sacrifice
10141 ours. */
10142 theirmark->op_next = ourmark->op_next;
10143 theirmark->op_flags = ourmark->op_flags;
ce335f37 10144 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 10145 op_null(ourmark);
10146 op_null(o);
10147 enter->op_private |= OPpITER_REVERSED;
10148 iter->op_private |= OPpITER_REVERSED;
10149
10150 break;
10151 }
e26df76a 10152
0477511c
NC		 10153 case OP_QR:
10154 case OP_MATCH:
29f2e912
NC		 10155 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10156 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10157 }
79072805 10158 break;
1830b3d9
BM		 10159
10160 case OP_CUSTOM: {
10161 Perl_cpeep_t cpeep =
10162 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10163 if (cpeep)
10164 cpeep(aTHX_ o, oldop);
10165 break;
10166 }
10167
79072805 10168 }
a0d0e21e 10169 oldop = o;
79072805 10170 }
a0d0e21e 10171 LEAVE;
79072805 10172}
beab0874 10173
1a0a2ba9
Z		 10174void
10175Perl_peep(pTHX_ register OP *o)
10176{
10177 CALL_RPEEP(o);
10178}
10179
9733086d
BM		 10180/*
10181=head1 Custom Operators
10182
10183=for apidoc Ao||custom_op_xop
10184Return the XOP structure for a given custom op. This function should be
10185considered internal to OP_NAME and the other access macros: use them instead.
10186
10187=cut
10188*/
10189
1830b3d9
BM		 10190const XOP *
10191Perl_custom_op_xop(pTHX_ const OP *o)
53e06cf0 10192{
1830b3d9
BM		 10193 SV *keysv;
10194 HE *he = NULL;
10195 XOP *xop;
10196
10197 static const XOP xop_null = { 0, 0, 0, 0, 0 };
53e06cf0 10198
1830b3d9
BM		 10199 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10200 assert(o->op_type == OP_CUSTOM);
7918f24d 10201
1830b3d9
BM		 10202 /* This is wrong. It assumes a function pointer can be cast to IV,
10203 * which isn't guaranteed, but this is what the old custom OP code
10204 * did. In principle it should be safer to Copy the bytes of the
10205 * pointer into a PV: since the new interface is hidden behind
10206 * functions, this can be changed later if necessary. */
10207 /* Change custom_op_xop if this ever happens */
10208 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
53e06cf0 10209
1830b3d9
BM		 10210 if (PL_custom_ops)
10211 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10212
10213 /* assume noone will have just registered a desc */
10214 if (!he && PL_custom_op_names &&
10215 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10216 ) {
10217 const char *pv;
10218 STRLEN l;
10219
10220 /* XXX does all this need to be shared mem? */
aca83993 10221 Newxz(xop, 1, XOP);
1830b3d9
BM		 10222 pv = SvPV(HeVAL(he), l);
10223 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10224 if (PL_custom_op_descs &&
10225 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10226 ) {
10227 pv = SvPV(HeVAL(he), l);
10228 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10229 }
10230 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10231 return xop;
10232 }
53e06cf0 10233
1830b3d9 10234 if (!he) return &xop_null;
53e06cf0 10235
1830b3d9
BM		 10236 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10237 return xop;
53e06cf0
SC		 10238}
10239
9733086d
BM		 10240/*
10241=for apidoc Ao||custom_op_register
10242Register a custom op. See L<perlguts/"Custom Operators">.
53e06cf0 10243
9733086d
BM		 10244=cut
10245*/
7918f24d 10246
1830b3d9
BM		 10247void
10248Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10249{
10250 SV *keysv;
10251
10252 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
53e06cf0 10253
1830b3d9
BM		 10254 /* see the comment in custom_op_xop */
10255 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
53e06cf0 10256
1830b3d9
BM		 10257 if (!PL_custom_ops)
10258 PL_custom_ops = newHV();
53e06cf0 10259
1830b3d9
BM		 10260 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10261 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
53e06cf0 10262}
19e8ce8e 10263
b8c38f0a
FC		 10264/*
10265=head1 Functions in file op.c
10266
10267=for apidoc core_prototype
10268This function assigns the prototype of the named core function to C<sv>, or
10269to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
a051f6c4
FC		 10270NULL if the core function has no prototype. C<code> is a code as returned
10271by C<keyword()>. It must be negative and unequal to -KEY_CORE.
b8c38f0a
FC		 10272
10273=cut
10274*/
10275
10276SV *
be1b855b 10277Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
b66130dd 10278 int * const opnum)
b8c38f0a 10279{
b8c38f0a
FC		 10280 int i = 0, n = 0, seen_question = 0, defgv = 0;
10281 I32 oa;
10282#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10283 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
9927957a 10284 bool nullret = FALSE;
b8c38f0a
FC		 10285
10286 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10287
b66130dd 10288 assert (code < 0 && code != -KEY_CORE);
b8c38f0a
FC		 10289
10290 if (!sv) sv = sv_newmortal();
10291
9927957a 10292#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
b8c38f0a
FC		 10293
10294 switch (-code) {
10295 case KEY_and : case KEY_chop: case KEY_chomp:
10296 case KEY_cmp : case KEY_exec: case KEY_eq :
10297 case KEY_ge : case KEY_gt : case KEY_le :
93e6f00e 10298 case KEY_lt : case KEY_ne : case KEY_or :
7391a163 10299 case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
9927957a
FC		 10300 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10301 case KEY_keys: retsetpvs("+", OP_KEYS);
10302 case KEY_values: retsetpvs("+", OP_VALUES);
10303 case KEY_each: retsetpvs("+", OP_EACH);
10304 case KEY_push: retsetpvs("+@", OP_PUSH);
10305 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10306 case KEY_pop: retsetpvs(";+", OP_POP);
10307 case KEY_shift: retsetpvs(";+", OP_SHIFT);
b8c38f0a 10308 case KEY_splice:
9927957a 10309 retsetpvs("+;$$@", OP_SPLICE);
b8c38f0a 10310 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
9927957a 10311 retsetpvs("", 0);
b8c38f0a
FC		 10312 case KEY_readpipe:
10313 name = "backtick";
10314 }
10315
10316#undef retsetpvs
10317
9927957a 10318 findopnum:
b8c38f0a
FC		 10319 while (i < MAXO) { /* The slow way. */
10320 if (strEQ(name, PL_op_name[i])
10321 || strEQ(name, PL_op_desc[i]))
10322 {
9927957a 10323 if (nullret) { assert(opnum); *opnum = i; return NULL; }
b8c38f0a
FC		 10324 goto found;
10325 }
10326 i++;
10327 }
d673215e 10328 assert(0); return NULL; /* Should not happen... */
b8c38f0a
FC		 10329 found:
10330 defgv = PL_opargs[i] & OA_DEFGV;
10331 oa = PL_opargs[i] >> OASHIFT;
10332 while (oa) {
465bc0f5 10333 if (oa & OA_OPTIONAL && !seen_question && (
ea5703f4 10334 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
465bc0f5 10335 )) {
b8c38f0a
FC		 10336 seen_question = 1;
10337 str[n++] = ';';
10338 }
10339 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10340 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10341 /* But globs are already references (kinda) */
10342 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10343 ) {
10344 str[n++] = '\\';
10345 }
1ecbeecf
FC		 10346 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10347 && !scalar_mod_type(NULL, i)) {
10348 str[n++] = '[';
10349 str[n++] = '$';
10350 str[n++] = '@';
10351 str[n++] = '%';
f79aa60b 10352 if (i == OP_LOCK) str[n++] = '&';
1ecbeecf
FC		 10353 str[n++] = '*';
10354 str[n++] = ']';
10355 }
10356 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
ea5703f4
FC		 10357 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10358 str[n-1] = '_'; defgv = 0;
10359 }
b8c38f0a
FC		 10360 oa = oa >> 4;
10361 }
dcbdef25 10362 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
b8c38f0a
FC		 10363 str[n++] = '\0';
10364 sv_setpvn(sv, str, n - 1);
9927957a 10365 if (opnum) *opnum = i;
b8c38f0a
FC		 10366 return sv;
10367}
10368
1e4b6aa1
FC		 10369OP *
10370Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
10371 const int opnum)
10372{
10373 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
c931b036 10374 OP *o;
1e4b6aa1
FC		 10375
10376 PERL_ARGS_ASSERT_CORESUB_OP;
10377
10378 switch(opnum) {
10379 case 0:
c2f605db 10380 return op_append_elem(OP_LINESEQ,
1e4b6aa1
FC		 10381 argop,
10382 newSLICEOP(0,
c2f605db 10383 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
1e4b6aa1
FC		 10384 newOP(OP_CALLER,0)
10385 )
c2f605db 10386 );
720d5b2f
FC		 10387 case OP_SELECT: /* which represents OP_SSELECT as well */
10388 if (code)
10389 return newCONDOP(
10390 0,
10391 newBINOP(OP_GT, 0,
10392 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
10393 newSVOP(OP_CONST, 0, newSVuv(1))
10394 ),
10395 coresub_op(newSVuv((UV)OP_SSELECT), 0,
10396 OP_SSELECT),
10397 coresub_op(coreargssv, 0, OP_SELECT)
10398 );
10399 /* FALL THROUGH */
1e4b6aa1
FC		 10400 default:
10401 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10402 case OA_BASEOP:
10403 return op_append_elem(
10404 OP_LINESEQ, argop,
10405 newOP(opnum,
10406 opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0)
10407 );
527d644b 10408 case OA_BASEOP_OR_UNOP:
c931b036 10409 o = newUNOP(opnum,0,argop);
ce0b554b
FC		 10410 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
10411 else {
c931b036 10412 onearg:
ce0b554b 10413 if (is_handle_constructor(o, 1))
c931b036 10414 argop->op_private |= OPpCOREARGS_DEREF1;
ce0b554b 10415 }
c931b036 10416 return o;
527d644b 10417 default:
c931b036
FC		 10418 o = convert(opnum,0,argop);
10419 if (is_handle_constructor(o, 2))
10420 argop->op_private |= OPpCOREARGS_DEREF2;
17008668
FC		 10421 if (scalar_mod_type(NULL, opnum))
10422 argop->op_private |= OPpCOREARGS_SCALARMOD;
7bc95ae1
FC		 10423 if (opnum == OP_SUBSTR) {
10424 o->op_private |= OPpMAYBE_LVSUB;
10425 return o;
10426 }
10427 else goto onearg;
1e4b6aa1
FC		 10428 }
10429 }
10430}
10431
beab0874
JT		 10432#include "XSUB.h"
10433
10434/* Efficient sub that returns a constant scalar value. */
10435static void
acfe0abc 10436const_sv_xsub(pTHX_ CV* cv)
beab0874 10437{
97aff369 10438 dVAR;
beab0874 10439 dXSARGS;
99ab892b 10440 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9cbac4c7 10441 if (items != 0) {
6f207bd3 10442 NOOP;
9cbac4c7 10443#if 0
fe13d51d 10444 /* diag_listed_as: SKIPME */
9cbac4c7 10445 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 10446 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 10447#endif
10448 }
99ab892b
NC		 10449 if (!sv) {
10450 XSRETURN(0);
10451 }
9a049f1c 10452 EXTEND(sp, 1);
99ab892b 10453 ST(0) = sv;
beab0874
JT		 10454 XSRETURN(1);
10455}
4946a0fa
NC		 10456
10457/*
10458 * Local variables:
10459 * c-indentation-style: bsd
10460 * c-basic-offset: 4
10461 * indent-tabs-mode: t
10462 * End:
10463 *
37442d52
RGS		 10464 * ex: set ts=8 sts=4 sw=4 noet:
10465 */
Unnamed repository; edit this file 'description' to name the repository.