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