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