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