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