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