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
Porting/mergelog is no more
[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
666e7765 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) {
f175a6ef 4278 deprecate("assignment to $[");
eb8433b7 4279 /* FIXME for MAD */
dbfe47cf
RD		 4280 /* Result of assignment is always 1 (or we'd be dead already) */
4281 return newSVOP(OP_CONST, 0, newSViv(1));
a0d0e21e 4282 }
10c8fecd
GS		 4283 curop = list(force_list(left));
4284 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 4285 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4 4286
fafafbaf
RD		 4287 if ((left->op_type == OP_LIST
4288 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4289 {
4290 OP* lop = ((LISTOP*)left)->op_first;
4291 maybe_common_vars = FALSE;
4292 while (lop) {
4293 if (lop->op_type == OP_PADSV ||
4294 lop->op_type == OP_PADAV ||
4295 lop->op_type == OP_PADHV ||
4296 lop->op_type == OP_PADANY) {
4297 if (!(lop->op_private & OPpLVAL_INTRO))
4298 maybe_common_vars = TRUE;
4299
4300 if (lop->op_private & OPpPAD_STATE) {
4301 if (left->op_private & OPpLVAL_INTRO) {
4302 /* Each variable in state($a, $b, $c) = ... */
4303 }
4304 else {
4305 /* Each state variable in
4306 (state $a, my $b, our $c, $d, undef) = ... */
4307 }
4308 yyerror(no_list_state);
4309 } else {
4310 /* Each my variable in
4311 (state $a, my $b, our $c, $d, undef) = ... */
4312 }
4313 } else if (lop->op_type == OP_UNDEF ||
4314 lop->op_type == OP_PUSHMARK) {
4315 /* undef may be interesting in
4316 (state $a, undef, state $c) */
4317 } else {
4318 /* Other ops in the list. */
4319 maybe_common_vars = TRUE;
4320 }
4321 lop = lop->op_sibling;
4322 }
4323 }
4324 else if ((left->op_private & OPpLVAL_INTRO)
4325 && ( left->op_type == OP_PADSV
4326 || left->op_type == OP_PADAV
4327 || left->op_type == OP_PADHV
4328 || left->op_type == OP_PADANY))
4329 {
0f907b96 4330 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
fafafbaf
RD		 4331 if (left->op_private & OPpPAD_STATE) {
4332 /* All single variable list context state assignments, hence
4333 state ($a) = ...
4334 (state $a) = ...
4335 state @a = ...
4336 state (@a) = ...
4337 (state @a) = ...
4338 state %a = ...
4339 state (%a) = ...
4340 (state %a) = ...
4341 */
4342 yyerror(no_list_state);
4343 }
4344 }
4345
dd2155a4
DM		 4346 /* PL_generation sorcery:
4347 * an assignment like ($a,$b) = ($c,$d) is easier than
4348 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4349 * To detect whether there are common vars, the global var
4350 * PL_generation is incremented for each assign op we compile.
4351 * Then, while compiling the assign op, we run through all the
4352 * variables on both sides of the assignment, setting a spare slot
4353 * in each of them to PL_generation. If any of them already have
4354 * that value, we know we've got commonality. We could use a
4355 * single bit marker, but then we'd have to make 2 passes, first
4356 * to clear the flag, then to test and set it. To find somewhere
931b58fb 4357 * to store these values, evil chicanery is done with SvUVX().
dd2155a4
DM		 4358 */
4359
fafafbaf 4360 if (maybe_common_vars) {
11343788 4361 OP *lastop = o;
3280af22 4362 PL_generation++;
11343788 4363 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 4364 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 4365 if (curop->op_type == OP_GV) {
638eceb6 4366 GV *gv = cGVOPx_gv(curop);
169d2d72
NC		 4367 if (gv == PL_defgv
4368 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
79072805 4369 break;
169d2d72 4370 GvASSIGN_GENERATION_set(gv, PL_generation);
79072805 4371 }
748a9306
LW		 4372 else if (curop->op_type == OP_PADSV ||
4373 curop->op_type == OP_PADAV ||
4374 curop->op_type == OP_PADHV ||
dd2155a4
DM		 4375 curop->op_type == OP_PADANY)
4376 {
4377 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 4378 == (STRLEN)PL_generation)
748a9306 4379 break;
b162af07 4380 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
dd2155a4 4381
748a9306 4382 }
79072805
LW		 4383 else if (curop->op_type == OP_RV2CV)
4384 break;
4385 else if (curop->op_type == OP_RV2SV ||
4386 curop->op_type == OP_RV2AV ||
4387 curop->op_type == OP_RV2HV ||
4388 curop->op_type == OP_RV2GV) {
4389 if (lastop->op_type != OP_GV) /* funny deref? */
4390 break;
4391 }
1167e5da 4392 else if (curop->op_type == OP_PUSHRE) {
b3f5893f 4393#ifdef USE_ITHREADS
20e98b0f 4394 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
159b6efe 4395 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
169d2d72
NC		 4396 if (gv == PL_defgv
4397 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
1167e5da 4398 break;
169d2d72 4399 GvASSIGN_GENERATION_set(gv, PL_generation);
20e98b0f
NC		 4400 }
4401#else
4402 GV *const gv
4403 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4404 if (gv) {
4405 if (gv == PL_defgv
4406 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4407 break;
169d2d72 4408 GvASSIGN_GENERATION_set(gv, PL_generation);
b2ffa427 4409 }
20e98b0f 4410#endif
1167e5da 4411 }
79072805
LW		 4412 else
4413 break;
4414 }
4415 lastop = curop;
4416 }
11343788 4417 if (curop != o)
10c8fecd 4418 o->op_private |= OPpASSIGN_COMMON;
461824dc 4419 }
9fdc7570 4420
e9cc17ba 4421 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
1496a290
AL		 4422 OP* tmpop = ((LISTOP*)right)->op_first;
4423 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
551405c4 4424 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 4425 if (left->op_type == OP_RV2AV &&
4426 !(left->op_private & OPpLVAL_INTRO) &&
11343788 4427 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 4428 {
4429 tmpop = ((UNOP*)left)->op_first;
20e98b0f
NC		 4430 if (tmpop->op_type == OP_GV
4431#ifdef USE_ITHREADS
4432 && !pm->op_pmreplrootu.op_pmtargetoff
4433#else
4434 && !pm->op_pmreplrootu.op_pmtargetgv
4435#endif
4436 ) {
971a9dd3 4437#ifdef USE_ITHREADS
20e98b0f
NC		 4438 pm->op_pmreplrootu.op_pmtargetoff
4439 = cPADOPx(tmpop)->op_padix;
971a9dd3
GS		 4440 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4441#else
20e98b0f 4442 pm->op_pmreplrootu.op_pmtargetgv
159b6efe 4443 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
a0714e2c 4444 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 4445#endif
c07a80fd 4446 pm->op_pmflags |= PMf_ONCE;
11343788 4447 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 4448 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 4449 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 4450 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 4451 op_free(o); /* blow off assign */
54310121 4452 right->op_flags &= ~OPf_WANT;
a5f75d66 4453 /* "I don't know and I don't care." */
c07a80fd 4454 return right;
4455 }
4456 }
4457 else {
e6438c1a 4458 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 4459 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4460 {
4461 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
b8de32d5 4462 if (SvIOK(sv) && SvIVX(sv) == 0)
3280af22 4463 sv_setiv(sv, PL_modcount+1);
c07a80fd 4464 }
4465 }
4466 }
4467 }
11343788 4468 return o;
79072805
LW		 4469 }
4470 if (!right)
4471 right = newOP(OP_UNDEF, 0);
4472 if (right->op_type == OP_READLINE) {
4473 right->op_flags |= OPf_STACKED;
463ee0b2 4474 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 4475 }
a0d0e21e 4476 else {
3280af22 4477 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 4478 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 4479 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 4480 if (PL_eval_start)
4481 PL_eval_start = 0;
748a9306 4482 else {
27aaedc1 4483 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
55b67815 4484 deprecate("assignment to $[");
27aaedc1
GG		 4485 op_free(o);
4486 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4487 o->op_private |= OPpCONST_ARYBASE;
4488 }
a0d0e21e
LW		 4489 }
4490 }
11343788 4491 return o;
79072805
LW		 4492}
4493
4494OP *
864dbfa3 4495Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 4496{
27da23d5 4497 dVAR;
e1ec3a88 4498 const U32 seq = intro_my();
79072805
LW		 4499 register COP *cop;
4500
b7dc083c 4501 NewOp(1101, cop, 1, COP);
57843af0 4502 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 4503 cop->op_type = OP_DBSTATE;
22c35a8c 4504 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 4505 }
4506 else {
4507 cop->op_type = OP_NEXTSTATE;
22c35a8c 4508 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 4509 }
eb160463 4510 cop->op_flags = (U8)flags;
623e6609 4511 CopHINTS_set(cop, PL_hints);
ff0cee69 4512#ifdef NATIVE_HINTS
4513 cop->op_private |= NATIVE_HINTS;
4514#endif
623e6609 4515 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 4516 cop->op_next = (OP*)cop;
4517
bbce6d69 4518 cop->cop_seq = seq;
7b0bddfa 4519 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
c28fe1ec
NC		 4520 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4521 */
72dc9ed5 4522 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
c28fe1ec
NC		 4523 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4524 if (cop->cop_hints_hash) {
cbb1fbea 4525 HINTS_REFCNT_LOCK;
c28fe1ec 4526 cop->cop_hints_hash->refcounted_he_refcnt++;
cbb1fbea 4527 HINTS_REFCNT_UNLOCK;
b3ca2e83 4528 }
dca6062a 4529 if (label) {
dca6062a 4530 cop->cop_hints_hash
012da8e5 4531 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
dca6062a
NC		 4532
4533 PL_hints |= HINT_BLOCK_SCOPE;
4534 /* It seems that we need to defer freeing this pointer, as other parts
4535 of the grammar end up wanting to copy it after this op has been
4536 created. */
4537 SAVEFREEPV(label);
dca6062a 4538 }
79072805 4539
53a7735b 4540 if (PL_parser && PL_parser->copline == NOLINE)
57843af0 4541 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 4542 else {
53a7735b
DM		 4543 CopLINE_set(cop, PL_parser->copline);
4544 if (PL_parser)
4545 PL_parser->copline = NOLINE;
79072805 4546 }
57843af0 4547#ifdef USE_ITHREADS
f4dd75d9 4548 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 4549#else
f4dd75d9 4550 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 4551#endif
11faa288 4552 CopSTASH_set(cop, PL_curstash);
79072805 4553
65269a95
TB		 4554 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4555 /* this line can have a breakpoint - store the cop in IV */
80a702cd
RGS		 4556 AV *av = CopFILEAVx(PL_curcop);
4557 if (av) {
4558 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4559 if (svp && *svp != &PL_sv_undef ) {
4560 (void)SvIOK_on(*svp);
4561 SvIV_set(*svp, PTR2IV(cop));
4562 }
1eb1540c 4563 }
93a17b20
LW		 4564 }
4565
f6f3a1fe
RGS		 4566 if (flags & OPf_SPECIAL)
4567 op_null((OP*)cop);
722969e2 4568 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 4569}
4570
bbce6d69 4571
79072805 4572OP *
864dbfa3 4573Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 4574{
27da23d5 4575 dVAR;
7918f24d
NC		 4576
4577 PERL_ARGS_ASSERT_NEWLOGOP;
4578
883ffac3
CS		 4579 return new_logop(type, flags, &first, &other);
4580}
4581
3bd495df 4582STATIC OP *
71c4dbc3
VP		 4583S_search_const(pTHX_ OP *o)
4584{
4585 PERL_ARGS_ASSERT_SEARCH_CONST;
4586
4587 switch (o->op_type) {
4588 case OP_CONST:
4589 return o;
4590 case OP_NULL:
4591 if (o->op_flags & OPf_KIDS)
4592 return search_const(cUNOPo->op_first);
4593 break;
4594 case OP_LEAVE:
4595 case OP_SCOPE:
4596 case OP_LINESEQ:
4597 {
4598 OP *kid;
4599 if (!(o->op_flags & OPf_KIDS))
4600 return NULL;
4601 kid = cLISTOPo->op_first;
4602 do {
4603 switch (kid->op_type) {
4604 case OP_ENTER:
4605 case OP_NULL:
4606 case OP_NEXTSTATE:
4607 kid = kid->op_sibling;
4608 break;
4609 default:
4610 if (kid != cLISTOPo->op_last)
4611 return NULL;
4612 goto last;
4613 }
4614 } while (kid);
4615 if (!kid)
4616 kid = cLISTOPo->op_last;
4617last:
4618 return search_const(kid);
4619 }
4620 }
4621
4622 return NULL;
4623}
4624
4625STATIC OP *
cea2e8a9 4626S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 4627{
27da23d5 4628 dVAR;
79072805 4629 LOGOP *logop;
11343788 4630 OP *o;
71c4dbc3
VP		 4631 OP *first;
4632 OP *other;
4633 OP *cstop = NULL;
edbe35ea 4634 int prepend_not = 0;
79072805 4635
7918f24d
NC		 4636 PERL_ARGS_ASSERT_NEW_LOGOP;
4637
71c4dbc3
VP		 4638 first = *firstp;
4639 other = *otherp;
4640
a0d0e21e
LW		 4641 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4642 return newBINOP(type, flags, scalar(first), scalar(other));
4643
e69777c1
GG		 4644 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4645
8990e307 4646 scalarboolean(first);
edbe35ea 4647 /* optimize AND and OR ops that have NOTs as children */
68726e16 4648 if (first->op_type == OP_NOT
b6214b80 4649 && (first->op_flags & OPf_KIDS)
edbe35ea
VP		 4650 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4651 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
b6214b80 4652 && !PL_madskills) {
79072805
LW		 4653 if (type == OP_AND || type == OP_OR) {
4654 if (type == OP_AND)
4655 type = OP_OR;
4656 else
4657 type = OP_AND;
07f3cdf5 4658 op_null(first);
edbe35ea 4659 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
07f3cdf5 4660 op_null(other);
edbe35ea
VP		 4661 prepend_not = 1; /* prepend a NOT op later */
4662 }
79072805
LW		 4663 }
4664 }
71c4dbc3
VP		 4665 /* search for a constant op that could let us fold the test */
4666 if ((cstop = search_const(first))) {
4667 if (cstop->op_private & OPpCONST_STRICT)
4668 no_bareword_allowed(cstop);
a2a5de95
NC		 4669 else if ((cstop->op_private & OPpCONST_BARE))
4670 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
71c4dbc3
VP		 4671 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4672 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4673 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5f66b61c 4674 *firstp = NULL;
d6fee5c7
DM		 4675 if (other->op_type == OP_CONST)
4676 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4677 if (PL_madskills) {
4678 OP *newop = newUNOP(OP_NULL, 0, other);
4679 op_getmad(first, newop, '1');
4680 newop->op_targ = type; /* set "was" field */
4681 return newop;
4682 }
4683 op_free(first);
dd3e51dc
VP		 4684 if (other->op_type == OP_LEAVE)
4685 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
79072805
LW		 4686 return other;
4687 }
4688 else {
7921d0f2 4689 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 4690 const OP *o2 = other;
7921d0f2
DM		 4691 if ( ! (o2->op_type == OP_LIST
4692 && (( o2 = cUNOPx(o2)->op_first))
4693 && o2->op_type == OP_PUSHMARK
4694 && (( o2 = o2->op_sibling)) )
4695 )
4696 o2 = other;
4697 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4698 || o2->op_type == OP_PADHV)
4699 && o2->op_private & OPpLVAL_INTRO
a2a5de95 4700 && !(o2->op_private & OPpPAD_STATE))
7921d0f2 4701 {
d1d15184
NC		 4702 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4703 "Deprecated use of my() in false conditional");
7921d0f2
DM		 4704 }
4705
5f66b61c 4706 *otherp = NULL;
d6fee5c7
DM		 4707 if (first->op_type == OP_CONST)
4708 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4709 if (PL_madskills) {
4710 first = newUNOP(OP_NULL, 0, first);
4711 op_getmad(other, first, '2');
4712 first->op_targ = type; /* set "was" field */
4713 }
4714 else
4715 op_free(other);
79072805
LW		 4716 return first;
4717 }
4718 }
041457d9
DM		 4719 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4720 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 4721 {
b22e6366
AL		 4722 const OP * const k1 = ((UNOP*)first)->op_first;
4723 const OP * const k2 = k1->op_sibling;
a6006777 4724 OPCODE warnop = 0;
4725 switch (first->op_type)
4726 {
4727 case OP_NULL:
4728 if (k2 && k2->op_type == OP_READLINE
4729 && (k2->op_flags & OPf_STACKED)
1c846c1f 4730 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 4731 {
a6006777 4732 warnop = k2->op_type;
72b16652 4733 }
a6006777 4734 break;
4735
4736 case OP_SASSIGN:
68dc0745 4737 if (k1->op_type == OP_READDIR
4738 || k1->op_type == OP_GLOB
72b16652 4739 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 4740 || k1->op_type == OP_EACH)
72b16652
GS		 4741 {
4742 warnop = ((k1->op_type == OP_NULL)
eb160463 4743 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 4744 }
a6006777 4745 break;
4746 }
8ebc5c01 4747 if (warnop) {
6867be6d 4748 const line_t oldline = CopLINE(PL_curcop);
53a7735b 4749 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 4750 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 4751 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 4752 PL_op_desc[warnop],
68dc0745 4753 ((warnop == OP_READLINE || warnop == OP_GLOB)
4754 ? " construct" : "() operator"));
57843af0 4755 CopLINE_set(PL_curcop, oldline);
8ebc5c01 4756 }
a6006777 4757 }
79072805
LW		 4758
4759 if (!other)
4760 return first;
4761
c963b151 4762 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 4763 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4764
b7dc083c 4765 NewOp(1101, logop, 1, LOGOP);
79072805 4766
eb160463 4767 logop->op_type = (OPCODE)type;
22c35a8c 4768 logop->op_ppaddr = PL_ppaddr[type];
79072805 4769 logop->op_first = first;
585ec06d 4770 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 4771 logop->op_other = LINKLIST(other);
eb160463 4772 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4773
4774 /* establish postfix order */
4775 logop->op_next = LINKLIST(first);
4776 first->op_next = (OP*)logop;
4777 first->op_sibling = other;
4778
463d09e6
RGS		 4779 CHECKOP(type,logop);
4780
edbe35ea 4781 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
11343788 4782 other->op_next = o;
79072805 4783
11343788 4784 return o;
79072805
LW		 4785}
4786
4787OP *
864dbfa3 4788Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 4789{
27da23d5 4790 dVAR;
1a67a97c
SM		 4791 LOGOP *logop;
4792 OP *start;
11343788 4793 OP *o;
71c4dbc3 4794 OP *cstop;
79072805 4795
7918f24d
NC		 4796 PERL_ARGS_ASSERT_NEWCONDOP;
4797
b1cb66bf 4798 if (!falseop)
4799 return newLOGOP(OP_AND, 0, first, trueop);
4800 if (!trueop)
4801 return newLOGOP(OP_OR, 0, first, falseop);
79072805 4802
8990e307 4803 scalarboolean(first);
71c4dbc3 4804 if ((cstop = search_const(first))) {
5b6782b2 4805 /* Left or right arm of the conditional? */
71c4dbc3 4806 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5b6782b2
NC		 4807 OP *live = left ? trueop : falseop;
4808 OP *const dead = left ? falseop : trueop;
71c4dbc3
VP		 4809 if (cstop->op_private & OPpCONST_BARE &&
4810 cstop->op_private & OPpCONST_STRICT) {
4811 no_bareword_allowed(cstop);
b22e6366 4812 }
5b6782b2
NC		 4813 if (PL_madskills) {
4814 /* This is all dead code when PERL_MAD is not defined. */
4815 live = newUNOP(OP_NULL, 0, live);
4816 op_getmad(first, live, 'C');
4817 op_getmad(dead, live, left ? 'e' : 't');
4818 } else {
4819 op_free(first);
4820 op_free(dead);
79072805 4821 }
ef9da979
FC		 4822 if (live->op_type == OP_LEAVE)
4823 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5b6782b2 4824 return live;
79072805 4825 }
1a67a97c
SM		 4826 NewOp(1101, logop, 1, LOGOP);
4827 logop->op_type = OP_COND_EXPR;
4828 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4829 logop->op_first = first;
585ec06d 4830 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 4831 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 4832 logop->op_other = LINKLIST(trueop);
4833 logop->op_next = LINKLIST(falseop);
79072805 4834
463d09e6
RGS		 4835 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4836 logop);
79072805
LW		 4837
4838 /* establish postfix order */
1a67a97c
SM		 4839 start = LINKLIST(first);
4840 first->op_next = (OP*)logop;
79072805 4841
b1cb66bf 4842 first->op_sibling = trueop;
4843 trueop->op_sibling = falseop;
1a67a97c 4844 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 4845
1a67a97c 4846 trueop->op_next = falseop->op_next = o;
79072805 4847
1a67a97c 4848 o->op_next = start;
11343788 4849 return o;
79072805
LW		 4850}
4851
4852OP *
864dbfa3 4853Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 4854{
27da23d5 4855 dVAR;
1a67a97c 4856 LOGOP *range;
79072805
LW		 4857 OP *flip;
4858 OP *flop;
1a67a97c 4859 OP *leftstart;
11343788 4860 OP *o;
79072805 4861
7918f24d
NC		 4862 PERL_ARGS_ASSERT_NEWRANGE;
4863
1a67a97c 4864 NewOp(1101, range, 1, LOGOP);
79072805 4865
1a67a97c
SM		 4866 range->op_type = OP_RANGE;
4867 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4868 range->op_first = left;
4869 range->op_flags = OPf_KIDS;
4870 leftstart = LINKLIST(left);
4871 range->op_other = LINKLIST(right);
eb160463 4872 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4873
4874 left->op_sibling = right;
4875
1a67a97c
SM		 4876 range->op_next = (OP*)range;
4877 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 4878 flop = newUNOP(OP_FLOP, 0, flip);
11343788 4879 o = newUNOP(OP_NULL, 0, flop);
79072805 4880 linklist(flop);
1a67a97c 4881 range->op_next = leftstart;
79072805
LW		 4882
4883 left->op_next = flip;
4884 right->op_next = flop;
4885
1a67a97c
SM		 4886 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4887 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 4888 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 4889 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4890
4891 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4892 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4893
11343788 4894 flip->op_next = o;
79072805 4895 if (!flip->op_private || !flop->op_private)
11343788 4896 linklist(o); /* blow off optimizer unless constant */
79072805 4897
11343788 4898 return o;
79072805
LW		 4899}
4900
4901OP *
864dbfa3 4902Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 4903{
97aff369 4904 dVAR;
463ee0b2 4905 OP* listop;
11343788 4906 OP* o;
73d840c0 4907 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 4908 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 4909
4910 PERL_UNUSED_ARG(debuggable);
93a17b20 4911
463ee0b2
LW		 4912 if (expr) {
4913 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4914 return block; /* do {} while 0 does once */
114c60ec
BG		 4915 if (expr->op_type == OP_READLINE
4916 || expr->op_type == OP_READDIR
4917 || expr->op_type == OP_GLOB
fb73857a 4918 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 4919 expr = newUNOP(OP_DEFINED, 0,
54b9620d 4920 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 4921 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 4922 const OP * const k1 = ((UNOP*)expr)->op_first;
4923 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 4924 switch (expr->op_type) {
1c846c1f 4925 case OP_NULL:
114c60ec 4926 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
55d729e4 4927 && (k2->op_flags & OPf_STACKED)
1c846c1f 4928 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 4929 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 4930 break;
55d729e4
GS		 4931
4932 case OP_SASSIGN:
06dc7ac6 4933 if (k1 && (k1->op_type == OP_READDIR
55d729e4 4934 || k1->op_type == OP_GLOB
6531c3e6 4935 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
06dc7ac6 4936 || k1->op_type == OP_EACH))
55d729e4
GS		 4937 expr = newUNOP(OP_DEFINED, 0, expr);
4938 break;
4939 }
774d564b 4940 }
463ee0b2 4941 }
93a17b20 4942
e1548254
RGS		 4943 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4944 * op, in listop. This is wrong. [perl #27024] */
4945 if (!block)
4946 block = newOP(OP_NULL, 0);
8990e307 4947 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 4948 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 4949
883ffac3
CS		 4950 if (listop)
4951 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 4952
11343788
MB		 4953 if (once && o != listop)
4954 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 4955
11343788
MB		 4956 if (o == listop)
4957 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 4958
11343788
MB		 4959 o->op_flags |= flags;
4960 o = scope(o);
4961 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4962 return o;
79072805
LW		 4963}
4964
4965OP *
a034e688
DM		 4966Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4967whileline, OP *expr, OP *block, OP *cont, I32 has_my)
79072805 4968{
27da23d5 4969 dVAR;
79072805 4970 OP *redo;
c445ea15 4971 OP *next = NULL;
79072805 4972 OP *listop;
11343788 4973 OP *o;
1ba6ee2b 4974 U8 loopflags = 0;
46c461b5
AL		 4975
4976 PERL_UNUSED_ARG(debuggable);
79072805 4977
2d03de9c 4978 if (expr) {
114c60ec
BG		 4979 if (expr->op_type == OP_READLINE
4980 || expr->op_type == OP_READDIR
4981 || expr->op_type == OP_GLOB
2d03de9c
AL		 4982 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4983 expr = newUNOP(OP_DEFINED, 0,
4984 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4985 } else if (expr->op_flags & OPf_KIDS) {
4986 const OP * const k1 = ((UNOP*)expr)->op_first;
4987 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4988 switch (expr->op_type) {
4989 case OP_NULL:
114c60ec 4990 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
2d03de9c
AL		 4991 && (k2->op_flags & OPf_STACKED)
4992 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4993 expr = newUNOP(OP_DEFINED, 0, expr);
4994 break;
55d729e4 4995
2d03de9c 4996 case OP_SASSIGN:
72c8de1a 4997 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 4998 || k1->op_type == OP_GLOB
4999 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
72c8de1a 5000 || k1->op_type == OP_EACH))
2d03de9c
AL		 5001 expr = newUNOP(OP_DEFINED, 0, expr);
5002 break;
5003 }
55d729e4 5004 }
748a9306 5005 }
79072805
LW		 5006
5007 if (!block)
5008 block = newOP(OP_NULL, 0);
a034e688 5009 else if (cont || has_my) {
87246558
GS		 5010 block = scope(block);
5011 }
79072805 5012
1ba6ee2b 5013 if (cont) {
79072805 5014 next = LINKLIST(cont);
1ba6ee2b 5015 }
fb73857a 5016 if (expr) {
551405c4 5017 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 5018 if (!next)
5019 next = unstack;
5020 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 5021 }
79072805 5022
ce3e5c45 5023 assert(block);
463ee0b2 5024 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
ce3e5c45 5025 assert(listop);
79072805
LW		 5026 redo = LINKLIST(listop);
5027
5028 if (expr) {
53a7735b 5029 PL_parser->copline = (line_t)whileline;
883ffac3
CS		 5030 scalar(listop);
5031 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 5032 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 5033 op_free(expr); /* oops, it's a while (0) */
463ee0b2 5034 op_free((OP*)loop);
5f66b61c 5035 return NULL; /* listop already freed by new_logop */
463ee0b2 5036 }
883ffac3 5037 if (listop)
497b47a8 5038 ((LISTOP*)listop)->op_last->op_next =
883ffac3 5039 (o == listop ? redo : LINKLIST(o));
79072805
LW		 5040 }
5041 else
11343788 5042 o = listop;
79072805
LW		 5043
5044 if (!loop) {
b7dc083c 5045 NewOp(1101,loop,1,LOOP);
79072805 5046 loop->op_type = OP_ENTERLOOP;
22c35a8c 5047 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 5048 loop->op_private = 0;
5049 loop->op_next = (OP*)loop;
5050 }
5051
11343788 5052 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 5053
5054 loop->op_redoop = redo;
11343788 5055 loop->op_lastop = o;
1ba6ee2b 5056 o->op_private |= loopflags;
79072805
LW		 5057
5058 if (next)
5059 loop->op_nextop = next;
5060 else
11343788 5061 loop->op_nextop = o;
79072805 5062
11343788
MB		 5063 o->op_flags |= flags;
5064 o->op_private |= (flags >> 8);
5065 return o;
79072805
LW		 5066}
5067
5068OP *
66a1b24b 5069Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
79072805 5070{
27da23d5 5071 dVAR;
79072805 5072 LOOP *loop;
fb73857a 5073 OP *wop;
4bbc6d12 5074 PADOFFSET padoff = 0;
4633a7c4 5075 I32 iterflags = 0;
241416b8 5076 I32 iterpflags = 0;
d4c19fe8 5077 OP *madsv = NULL;
79072805 5078
7918f24d
NC		 5079 PERL_ARGS_ASSERT_NEWFOROP;
5080
79072805 5081 if (sv) {
85e6fe83 5082 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 5083 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 5084 sv->op_type = OP_RV2GV;
22c35a8c 5085 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0be9a6bb
RH		 5086
5087 /* The op_type check is needed to prevent a possible segfault
5088 * if the loop variable is undeclared and 'strict vars' is in
5089 * effect. This is illegal but is nonetheless parsed, so we
5090 * may reach this point with an OP_CONST where we're expecting
5091 * an OP_GV.
5092 */
5093 if (cUNOPx(sv)->op_first->op_type == OP_GV
5094 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
0d863452 5095 iterpflags |= OPpITER_DEF;
79072805 5096 }
85e6fe83 5097 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 5098 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 5099 padoff = sv->op_targ;
eb8433b7
NC		 5100 if (PL_madskills)
5101 madsv = sv;
5102 else {
5103 sv->op_targ = 0;
5104 op_free(sv);
5105 }
5f66b61c 5106 sv = NULL;
85e6fe83 5107 }
79072805 5108 else
cea2e8a9 5109 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
f8503592
NC		 5110 if (padoff) {
5111 SV *const namesv = PAD_COMPNAME_SV(padoff);
5112 STRLEN len;
5113 const char *const name = SvPV_const(namesv, len);
5114
5115 if (len == 2 && name[0] == '$' && name[1] == '_')
5116 iterpflags |= OPpITER_DEF;
5117 }
79072805
LW		 5118 }
5119 else {
f8f98e0a 5120 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
00b1698f 5121 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 5122 sv = newGVOP(OP_GV, 0, PL_defgv);
5123 }
5124 else {
5125 padoff = offset;
aabe9514 5126 }
0d863452 5127 iterpflags |= OPpITER_DEF;
79072805 5128 }
5f05dabc 5129 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 5130 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 5131 iterflags |= OPf_STACKED;
5132 }
89ea2908
GA		 5133 else if (expr->op_type == OP_NULL &&
5134 (expr->op_flags & OPf_KIDS) &&
5135 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5136 {
5137 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5138 * set the STACKED flag to indicate that these values are to be
5139 * treated as min/max values by 'pp_iterinit'.
5140 */
d4c19fe8 5141 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 5142 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 5143 OP* const left = range->op_first;
5144 OP* const right = left->op_sibling;
5152d7c7 5145 LISTOP* listop;
89ea2908
GA		 5146
5147 range->op_flags &= ~OPf_KIDS;
5f66b61c 5148 range->op_first = NULL;
89ea2908 5149
5152d7c7 5150 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 5151 listop->op_first->op_next = range->op_next;
5152 left->op_next = range->op_other;
5152d7c7
GS		 5153 right->op_next = (OP*)listop;
5154 listop->op_next = listop->op_first;
89ea2908 5155
eb8433b7
NC		 5156#ifdef PERL_MAD
5157 op_getmad(expr,(OP*)listop,'O');
5158#else
89ea2908 5159 op_free(expr);
eb8433b7 5160#endif
5152d7c7 5161 expr = (OP*)(listop);
93c66552 5162 op_null(expr);
89ea2908
GA		 5163 iterflags |= OPf_STACKED;
5164 }
5165 else {
5166 expr = mod(force_list(expr), OP_GREPSTART);
5167 }
5168
4633a7c4 5169 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 5170 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 5171 assert(!loop->op_next);
241416b8 5172 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 5173 * for our $x () sets OPpOUR_INTRO */
c5661c80 5174 loop->op_private = (U8)iterpflags;
b7dc083c 5175#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 5176 {
5177 LOOP *tmp;
5178 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 5179 Copy(loop,tmp,1,LISTOP);
bfafaa29 5180 S_op_destroy(aTHX_ (OP*)loop);
155aba94
GS		 5181 loop = tmp;
5182 }
b7dc083c 5183#else
10edeb5d 5184 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
1c846c1f 5185#endif
85e6fe83 5186 loop->op_targ = padoff;
a034e688 5187 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 5188 if (madsv)
5189 op_getmad(madsv, (OP*)loop, 'v');
53a7735b 5190 PL_parser->copline = forline;
fb73857a 5191 return newSTATEOP(0, label, wop);
79072805
LW		 5192}
5193
8990e307 5194OP*
864dbfa3 5195Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 5196{
97aff369 5197 dVAR;
11343788 5198 OP *o;
2d8e6c8d 5199
7918f24d
NC		 5200 PERL_ARGS_ASSERT_NEWLOOPEX;
5201
e69777c1
GG		 5202 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5203
8990e307 5204 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 5205 /* "last()" means "last" */
5206 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5207 o = newOP(type, OPf_SPECIAL);
5208 else {
ea71c68d 5209 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4ea561bc 5210 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
666ea192 5211 : ""));
cdaebead 5212 }
eb8433b7
NC		 5213#ifdef PERL_MAD
5214 op_getmad(label,o,'L');
5215#else
8990e307 5216 op_free(label);
eb8433b7 5217#endif
8990e307
LW		 5218 }
5219 else {
e3aba57a
RGS		 5220 /* Check whether it's going to be a goto &function */
5221 if (label->op_type == OP_ENTERSUB
5222 && !(label->op_flags & OPf_STACKED))
a0d0e21e 5223 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 5224 o = newUNOP(type, OPf_STACKED, label);
8990e307 5225 }
3280af22 5226 PL_hints |= HINT_BLOCK_SCOPE;
11343788 5227 return o;
8990e307
LW		 5228}
5229
0d863452
RH		 5230/* if the condition is a literal array or hash
5231 (or @{ ... } etc), make a reference to it.
5232 */
5233STATIC OP *
5234S_ref_array_or_hash(pTHX_ OP *cond)
5235{
5236 if (cond
5237 && (cond->op_type == OP_RV2AV
5238 || cond->op_type == OP_PADAV
5239 || cond->op_type == OP_RV2HV
5240 || cond->op_type == OP_PADHV))
5241
5242 return newUNOP(OP_REFGEN,
5243 0, mod(cond, OP_REFGEN));
5244
5245 else
5246 return cond;
5247}
5248
5249/* These construct the optree fragments representing given()
5250 and when() blocks.
5251
5252 entergiven and enterwhen are LOGOPs; the op_other pointer
5253 points up to the associated leave op. We need this so we
5254 can put it in the context and make break/continue work.
5255 (Also, of course, pp_enterwhen will jump straight to
5256 op_other if the match fails.)
5257 */
5258
4136a0f7 5259STATIC OP *
0d863452
RH		 5260S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5261 I32 enter_opcode, I32 leave_opcode,
5262 PADOFFSET entertarg)
5263{
97aff369 5264 dVAR;
0d863452
RH		 5265 LOGOP *enterop;
5266 OP *o;
5267
7918f24d
NC		 5268 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5269
0d863452 5270 NewOp(1101, enterop, 1, LOGOP);
61a59f30 5271 enterop->op_type = (Optype)enter_opcode;
0d863452
RH		 5272 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5273 enterop->op_flags = (U8) OPf_KIDS;
5274 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5275 enterop->op_private = 0;
5276
5277 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5278
5279 if (cond) {
5280 enterop->op_first = scalar(cond);
5281 cond->op_sibling = block;
5282
5283 o->op_next = LINKLIST(cond);
5284 cond->op_next = (OP *) enterop;
5285 }
5286 else {
5287 /* This is a default {} block */
5288 enterop->op_first = block;
5289 enterop->op_flags |= OPf_SPECIAL;
5290
5291 o->op_next = (OP *) enterop;
5292 }
5293
5294 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5295 entergiven and enterwhen both
5296 use ck_null() */
5297
5298 enterop->op_next = LINKLIST(block);
5299 block->op_next = enterop->op_other = o;
5300
5301 return o;
5302}
5303
5304/* Does this look like a boolean operation? For these purposes
5305 a boolean operation is:
5306 - a subroutine call [*]
5307 - a logical connective
5308 - a comparison operator
5309 - a filetest operator, with the exception of -s -M -A -C
5310 - defined(), exists() or eof()
5311 - /$re/ or $foo =~ /$re/
5312
5313 [*] possibly surprising
5314 */
4136a0f7 5315STATIC bool
ef519e13 5316S_looks_like_bool(pTHX_ const OP *o)
0d863452 5317{
97aff369 5318 dVAR;
7918f24d
NC		 5319
5320 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5321
0d863452
RH		 5322 switch(o->op_type) {
5323 case OP_OR:
f92e1a16 5324 case OP_DOR:
0d863452
RH		 5325 return looks_like_bool(cLOGOPo->op_first);
5326
5327 case OP_AND:
5328 return (
5329 looks_like_bool(cLOGOPo->op_first)
5330 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5331
1e1d4b91 5332 case OP_NULL:
08fe1c44 5333 case OP_SCALAR:
1e1d4b91
JJ		 5334 return (
5335 o->op_flags & OPf_KIDS
5336 && looks_like_bool(cUNOPo->op_first));
5337
0d863452
RH		 5338 case OP_ENTERSUB:
5339
5340 case OP_NOT: case OP_XOR:
0d863452
RH		 5341
5342 case OP_EQ: case OP_NE: case OP_LT:
5343 case OP_GT: case OP_LE: case OP_GE:
5344
5345 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5346 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5347
5348 case OP_SEQ: case OP_SNE: case OP_SLT:
5349 case OP_SGT: case OP_SLE: case OP_SGE:
5350
5351 case OP_SMARTMATCH:
5352
5353 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5354 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5355 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5356 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5357 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5358 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5359 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5360 case OP_FTTEXT: case OP_FTBINARY:
5361
5362 case OP_DEFINED: case OP_EXISTS:
5363 case OP_MATCH: case OP_EOF:
5364
f118ea0d
RGS		 5365 case OP_FLOP:
5366
0d863452
RH		 5367 return TRUE;
5368
5369 case OP_CONST:
5370 /* Detect comparisons that have been optimized away */
5371 if (cSVOPo->op_sv == &PL_sv_yes
5372 || cSVOPo->op_sv == &PL_sv_no)
5373
5374 return TRUE;
6e03d743
RGS		 5375 else
5376 return FALSE;
6e03d743 5377
0d863452
RH		 5378 /* FALL THROUGH */
5379 default:
5380 return FALSE;
5381 }
5382}
5383
5384OP *
5385Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5386{
97aff369 5387 dVAR;
7918f24d 5388 PERL_ARGS_ASSERT_NEWGIVENOP;
0d863452
RH		 5389 return newGIVWHENOP(
5390 ref_array_or_hash(cond),
5391 block,
5392 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5393 defsv_off);
5394}
5395
5396/* If cond is null, this is a default {} block */
5397OP *
5398Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5399{
ef519e13 5400 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 5401 OP *cond_op;
5402
7918f24d
NC		 5403 PERL_ARGS_ASSERT_NEWWHENOP;
5404
0d863452
RH		 5405 if (cond_llb)
5406 cond_op = cond;
5407 else {
5408 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5409 newDEFSVOP(),
5410 scalar(ref_array_or_hash(cond)));
5411 }
5412
5413 return newGIVWHENOP(
5414 cond_op,
5415 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5416 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5417}
5418
7dafbf52
DM		 5419/*
5420=for apidoc cv_undef
5421
5422Clear out all the active components of a CV. This can happen either
5423by an explicit C<undef &foo>, or by the reference count going to zero.
5424In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5425children can still follow the full lexical scope chain.
5426
5427=cut
5428*/
5429
79072805 5430void
864dbfa3 5431Perl_cv_undef(pTHX_ CV *cv)
79072805 5432{
27da23d5 5433 dVAR;
503de470 5434
7918f24d
NC		 5435 PERL_ARGS_ASSERT_CV_UNDEF;
5436
503de470
DM		 5437 DEBUG_X(PerlIO_printf(Perl_debug_log,
5438 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5439 PTR2UV(cv), PTR2UV(PL_comppad))
5440 );
5441
a636914a 5442#ifdef USE_ITHREADS
aed2304a 5443 if (CvFILE(cv) && !CvISXSUB(cv)) {
35f1c1c7 5444 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 5445 Safefree(CvFILE(cv));
a636914a 5446 }
b3123a61 5447 CvFILE(cv) = NULL;
a636914a
RH		 5448#endif
5449
aed2304a 5450 if (!CvISXSUB(cv) && CvROOT(cv)) {
bb172083 5451 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
cea2e8a9 5452 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 5453 ENTER;
a0d0e21e 5454
f3548bdc 5455 PAD_SAVE_SETNULLPAD();
a0d0e21e 5456
282f25c9 5457 op_free(CvROOT(cv));
5f66b61c
AL		 5458 CvROOT(cv) = NULL;
5459 CvSTART(cv) = NULL;
8990e307 5460 LEAVE;
79072805 5461 }
ad64d0ec 5462 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
b3f91e91 5463 CvGV_set(cv, NULL);
a3985cdc
DM		 5464
5465 pad_undef(cv);
5466
7dafbf52
DM		 5467 /* remove CvOUTSIDE unless this is an undef rather than a free */
5468 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5469 if (!CvWEAKOUTSIDE(cv))
5470 SvREFCNT_dec(CvOUTSIDE(cv));
601f1833 5471 CvOUTSIDE(cv) = NULL;
7dafbf52 5472 }
beab0874 5473 if (CvCONST(cv)) {
ad64d0ec 5474 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
beab0874
JT		 5475 CvCONST_off(cv);
5476 }
d04ba589 5477 if (CvISXSUB(cv) && CvXSUB(cv)) {
96a5add6 5478 CvXSUB(cv) = NULL;
50762d59 5479 }
cfc1e951 5480 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
803f2748 5481 * ref status of CvOUTSIDE and CvGV */
cfc1e951 5482 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
79072805
LW		 5483}
5484
3fe9a6f1 5485void
cbf82dd0
NC		 5486Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5487 const STRLEN len)
5488{
7918f24d
NC		 5489 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5490
cbf82dd0
NC		 5491 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5492 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5493 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5494 || (p && (len != SvCUR(cv) /* Not the same length. */
5495 || memNE(p, SvPVX_const(cv), len))))
5496 && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 5497 SV* const msg = sv_newmortal();
a0714e2c 5498 SV* name = NULL;
3fe9a6f1 5499
5500 if (gv)
bd61b366 5501 gv_efullname3(name = sv_newmortal(), gv, NULL);
6502358f 5502 sv_setpvs(msg, "Prototype mismatch:");
46fc3d4c 5503 if (name)
be2597df 5504 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
3fe9a6f1 5505 if (SvPOK(cv))
be2597df 5506 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
ebe643b9 5507 else
396482e1
GA		 5508 sv_catpvs(msg, ": none");
5509 sv_catpvs(msg, " vs ");
46fc3d4c 5510 if (p)
cbf82dd0 5511 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
46fc3d4c 5512 else
396482e1 5513 sv_catpvs(msg, "none");
be2597df 5514 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 5515 }
5516}
5517
35f1c1c7
SB		 5518static void const_sv_xsub(pTHX_ CV* cv);
5519
beab0874 5520/*
ccfc67b7
JH		 5521
5522=head1 Optree Manipulation Functions
5523
beab0874
JT		 5524=for apidoc cv_const_sv
5525
5526If C<cv> is a constant sub eligible for inlining. returns the constant
5527value returned by the sub. Otherwise, returns NULL.
5528
5529Constant subs can be created with C<newCONSTSUB> or as described in
5530L<perlsub/"Constant Functions">.
5531
5532=cut
5533*/
760ac839 5534SV *
d45f5b30 5535Perl_cv_const_sv(pTHX_ const CV *const cv)
760ac839 5536{
96a5add6 5537 PERL_UNUSED_CONTEXT;
5069cc75
NC		 5538 if (!cv)
5539 return NULL;
5540 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5541 return NULL;
ad64d0ec 5542 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
fe5e78ed 5543}
760ac839 5544
b5c19bd7
DM		 5545/* op_const_sv: examine an optree to determine whether it's in-lineable.
5546 * Can be called in 3 ways:
5547 *
5548 * !cv
5549 * look for a single OP_CONST with attached value: return the value
5550 *
5551 * cv && CvCLONE(cv) && !CvCONST(cv)
5552 *
5553 * examine the clone prototype, and if contains only a single
5554 * OP_CONST referencing a pad const, or a single PADSV referencing
5555 * an outer lexical, return a non-zero value to indicate the CV is
5556 * a candidate for "constizing" at clone time
5557 *
5558 * cv && CvCONST(cv)
5559 *
5560 * We have just cloned an anon prototype that was marked as a const
5561 * candidiate. Try to grab the current value, and in the case of
5562 * PADSV, ignore it if it has multiple references. Return the value.
5563 */
5564
fe5e78ed 5565SV *
6867be6d 5566Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 5567{
97aff369 5568 dVAR;
a0714e2c 5569 SV *sv = NULL;
fe5e78ed 5570
c631f32b
GG		 5571 if (PL_madskills)
5572 return NULL;
5573
0f79a09d 5574 if (!o)
a0714e2c 5575 return NULL;
1c846c1f
NIS		 5576
5577 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 5578 o = cLISTOPo->op_first->op_sibling;
5579
5580 for (; o; o = o->op_next) {
890ce7af 5581 const OPCODE type = o->op_type;
fe5e78ed 5582
1c846c1f 5583 if (sv && o->op_next == o)
fe5e78ed 5584 return sv;
e576b457
JT		 5585 if (o->op_next != o) {
5586 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5587 continue;
5588 if (type == OP_DBSTATE)
5589 continue;
5590 }
54310121 5591 if (type == OP_LEAVESUB || type == OP_RETURN)
5592 break;
5593 if (sv)
a0714e2c 5594 return NULL;
7766f137 5595 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 5596 sv = cSVOPo->op_sv;
b5c19bd7 5597 else if (cv && type == OP_CONST) {
dd2155a4 5598 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 5599 if (!sv)
a0714e2c 5600 return NULL;
b5c19bd7
DM		 5601 }
5602 else if (cv && type == OP_PADSV) {
5603 if (CvCONST(cv)) { /* newly cloned anon */
5604 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5605 /* the candidate should have 1 ref from this pad and 1 ref
5606 * from the parent */
5607 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 5608 return NULL;
beab0874 5609 sv = newSVsv(sv);
b5c19bd7
DM		 5610 SvREADONLY_on(sv);
5611 return sv;
5612 }
5613 else {
5614 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5615 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 5616 }
760ac839 5617 }
b5c19bd7 5618 else {
a0714e2c 5619 return NULL;
b5c19bd7 5620 }
760ac839
LW		 5621 }
5622 return sv;
5623}
5624
eb8433b7
NC		 5625#ifdef PERL_MAD
5626OP *
5627#else
09bef843 5628void
eb8433b7 5629#endif
09bef843
SB		 5630Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5631{
99129197
NC		 5632#if 0
5633 /* This would be the return value, but the return cannot be reached. */
eb8433b7
NC		 5634 OP* pegop = newOP(OP_NULL, 0);
5635#endif
5636
46c461b5
AL		 5637 PERL_UNUSED_ARG(floor);
5638
09bef843
SB		 5639 if (o)
5640 SAVEFREEOP(o);
5641 if (proto)
5642 SAVEFREEOP(proto);
5643 if (attrs)
5644 SAVEFREEOP(attrs);
5645 if (block)
5646 SAVEFREEOP(block);
5647 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
eb8433b7 5648#ifdef PERL_MAD
99129197 5649 NORETURN_FUNCTION_END;
eb8433b7 5650#endif
09bef843
SB		 5651}
5652
748a9306 5653CV *
864dbfa3 5654Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 5655{
5f66b61c 5656 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
09bef843
SB		 5657}
5658
5659CV *
5660Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5661{
27da23d5 5662 dVAR;
83ee9e09 5663 GV *gv;
5c144d81 5664 const char *ps;
52a9a866 5665 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
c445ea15 5666 register CV *cv = NULL;
beab0874 5667 SV *const_sv;
b48b272a
NC		 5668 /* If the subroutine has no body, no attributes, and no builtin attributes
5669 then it's just a sub declaration, and we may be able to get away with
5670 storing with a placeholder scalar in the symbol table, rather than a
5671 full GV and CV. If anything is present then it will take a full CV to
5672 store it. */
5673 const I32 gv_fetch_flags
eb8433b7
NC		 5674 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5675 || PL_madskills)
b48b272a 5676 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4ea561bc 5677 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
ed4a8a9b 5678 bool has_name;
8e742a20
MHM		 5679
5680 if (proto) {
5681 assert(proto->op_type == OP_CONST);
4ea561bc 5682 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8e742a20
MHM		 5683 }
5684 else
bd61b366 5685 ps = NULL;
8e742a20 5686
ed4a8a9b
NC		 5687 if (name) {
5688 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5689 has_name = TRUE;
5690 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 5691 SV * const sv = sv_newmortal();
c99da370
JH		 5692 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5693 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 5694 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
ed4a8a9b
NC		 5695 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5696 has_name = TRUE;
c1754fce
NC		 5697 } else if (PL_curstash) {
5698 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 5699 has_name = FALSE;
c1754fce
NC		 5700 } else {
5701 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 5702 has_name = FALSE;
c1754fce 5703 }
83ee9e09 5704
eb8433b7
NC		 5705 if (!PL_madskills) {
5706 if (o)
5707 SAVEFREEOP(o);
5708 if (proto)
5709 SAVEFREEOP(proto);
5710 if (attrs)
5711 SAVEFREEOP(attrs);
5712 }
3fe9a6f1 5713
09bef843 5714 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 5715 maximum a prototype before. */
5716 if (SvTYPE(gv) > SVt_NULL) {
ad64d0ec 5717 if (!SvPOK((const SV *)gv)
9b387841 5718 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
f248d071 5719 {
9b387841 5720 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 5721 }
ea726b52 5722 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
55d729e4
GS		 5723 }
5724 if (ps)
ad64d0ec 5725 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
55d729e4 5726 else
ad64d0ec 5727 sv_setiv(MUTABLE_SV(gv), -1);
e1a479c5 5728
3280af22
NIS		 5729 SvREFCNT_dec(PL_compcv);
5730 cv = PL_compcv = NULL;
beab0874 5731 goto done;
55d729e4
GS		 5732 }
5733
601f1833 5734 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 5735
eb8433b7
NC		 5736 if (!block || !ps || *ps || attrs
5737 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5738#ifdef PERL_MAD
5739 || block->op_type == OP_NULL
5740#endif
5741 )
a0714e2c 5742 const_sv = NULL;
beab0874 5743 else
601f1833 5744 const_sv = op_const_sv(block, NULL);
beab0874
JT		 5745
5746 if (cv) {
6867be6d 5747 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 5748
60ed1d8c
GS		 5749 /* if the subroutine doesn't exist and wasn't pre-declared
5750 * with a prototype, assume it will be AUTOLOADed,
5751 * skipping the prototype check
5752 */
5753 if (exists || SvPOK(cv))
cbf82dd0 5754 cv_ckproto_len(cv, gv, ps, ps_len);
68dc0745 5755 /* already defined (or promised)? */
60ed1d8c 5756 if (exists || GvASSUMECV(gv)) {
eb8433b7
NC		 5757 if ((!block
5758#ifdef PERL_MAD
5759 || block->op_type == OP_NULL
5760#endif
5761 )&& !attrs) {
d3cea301
SB		 5762 if (CvFLAGS(PL_compcv)) {
5763 /* might have had built-in attrs applied */
963d9ce9 5764 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
885ef6f5
GG		 5765 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
5766 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
d3cea301 5767 }
aa689395 5768 /* just a "sub foo;" when &foo is already defined */
3280af22 5769 SAVEFREESV(PL_compcv);
aa689395 5770 goto done;
5771 }
eb8433b7
NC		 5772 if (block
5773#ifdef PERL_MAD
5774 && block->op_type != OP_NULL
5775#endif
5776 ) {
beab0874
JT		 5777 if (ckWARN(WARN_REDEFINE)
5778 || (CvCONST(cv)
5779 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5780 {
6867be6d 5781 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 5782 if (PL_parser && PL_parser->copline != NOLINE)
5783 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 5784 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 5785 CvCONST(cv) ? "Constant subroutine %s redefined"
5786 : "Subroutine %s redefined", name);
beab0874
JT		 5787 CopLINE_set(PL_curcop, oldline);
5788 }
eb8433b7
NC		 5789#ifdef PERL_MAD
5790 if (!PL_minus_c) /* keep old one around for madskills */
5791#endif
5792 {
5793 /* (PL_madskills unset in used file.) */
5794 SvREFCNT_dec(cv);
5795 }
601f1833 5796 cv = NULL;
79072805 5797 }
79072805
LW		 5798 }
5799 }
beab0874 5800 if (const_sv) {
f84c484e 5801 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 5802 if (cv) {
0768512c 5803 assert(!CvROOT(cv) && !CvCONST(cv));
ad64d0ec 5804 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
beab0874
JT		 5805 CvXSUBANY(cv).any_ptr = const_sv;
5806 CvXSUB(cv) = const_sv_xsub;
5807 CvCONST_on(cv);
d04ba589 5808 CvISXSUB_on(cv);
beab0874
JT		 5809 }
5810 else {
601f1833 5811 GvCV(gv) = NULL;
beab0874
JT		 5812 cv = newCONSTSUB(NULL, name, const_sv);
5813 }
e1a479c5
BB		 5814 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5815 (CvGV(cv) && GvSTASH(CvGV(cv)))
5816 ? GvSTASH(CvGV(cv))
5817 : CvSTASH(cv)
5818 ? CvSTASH(cv)
5819 : PL_curstash
5820 );
eb8433b7
NC		 5821 if (PL_madskills)
5822 goto install_block;
beab0874
JT		 5823 op_free(block);
5824 SvREFCNT_dec(PL_compcv);
5825 PL_compcv = NULL;
beab0874
JT		 5826 goto done;
5827 }
09330df8
Z		 5828 if (cv) { /* must reuse cv if autoloaded */
5829 /* transfer PL_compcv to cv */
5830 if (block
eb8433b7 5831#ifdef PERL_MAD
09330df8 5832 && block->op_type != OP_NULL
eb8433b7 5833#endif
09330df8 5834 ) {
eac910c8 5835 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
09330df8 5836 cv_undef(cv);
eac910c8 5837 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
09330df8
Z		 5838 if (!CvWEAKOUTSIDE(cv))
5839 SvREFCNT_dec(CvOUTSIDE(cv));
5840 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5841 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5842 CvOUTSIDE(PL_compcv) = 0;
5843 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5844 CvPADLIST(PL_compcv) = 0;
5845 /* inner references to PL_compcv must be fixed up ... */
5846 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5847 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5848 ++PL_sub_generation;
4c74a7df
DM		 5849 if (CvSTASH(cv))
5850 sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
09bef843
SB		 5851 }
5852 else {
09330df8
Z		 5853 /* Might have had built-in attributes applied -- propagate them. */
5854 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
09bef843 5855 }
282f25c9 5856 /* ... before we throw it away */
3280af22 5857 SvREFCNT_dec(PL_compcv);
b5c19bd7 5858 PL_compcv = cv;
a0d0e21e
LW		 5859 }
5860 else {
3280af22 5861 cv = PL_compcv;
44a8e56a 5862 if (name) {
5863 GvCV(gv) = cv;
eb8433b7
NC		 5864 if (PL_madskills) {
5865 if (strEQ(name, "import")) {
ad64d0ec 5866 PL_formfeed = MUTABLE_SV(cv);
06f07c2f 5867 /* diag_listed_as: SKIPME */
fea10cf6 5868 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
eb8433b7
NC		 5869 }
5870 }
44a8e56a 5871 GvCVGEN(gv) = 0;
e1a479c5 5872 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
44a8e56a 5873 }
a0d0e21e 5874 }
09330df8 5875 if (!CvGV(cv)) {
b3f91e91 5876 CvGV_set(cv, gv);
09330df8
Z		 5877 CvFILE_set_from_cop(cv, PL_curcop);
5878 CvSTASH(cv) = PL_curstash;
4c74a7df
DM		 5879 if (PL_curstash)
5880 Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
09330df8
Z		 5881 }
5882 if (attrs) {
5883 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5884 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5885 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5886 }
8990e307 5887
3fe9a6f1 5888 if (ps)
ad64d0ec 5889 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
4633a7c4 5890
13765c85 5891 if (PL_parser && PL_parser->error_count) {
c07a80fd 5892 op_free(block);
5f66b61c 5893 block = NULL;
68dc0745 5894 if (name) {
6867be6d 5895 const char *s = strrchr(name, ':');
68dc0745 5896 s = s ? s+1 : name;
6d4c2119 5897 if (strEQ(s, "BEGIN")) {
e1ec3a88 5898 const char not_safe[] =
6d4c2119 5899 "BEGIN not safe after errors--compilation aborted";
faef0170 5900 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 5901 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 5902 else {
5903 /* force display of errors found but not reported */
38a03e6e 5904 sv_catpv(ERRSV, not_safe);
be2597df 5905 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6d4c2119
CS		 5906 }
5907 }
68dc0745 5908 }
c07a80fd 5909 }
eb8433b7 5910 install_block:
beab0874
JT		 5911 if (!block)
5912 goto done;
a0d0e21e 5913
aac018bb
NC		 5914 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5915 the debugger could be able to set a breakpoint in, so signal to
5916 pp_entereval that it should not throw away any saved lines at scope
5917 exit. */
5918
fd06b02c 5919 PL_breakable_sub_gen++;
7766f137 5920 if (CvLVALUE(cv)) {
78f9721b
SM		 5921 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5922 mod(scalarseq(block), OP_LEAVESUBLV));
7e5d8ed2 5923 block->op_attached = 1;
7766f137
GS		 5924 }
5925 else {
09c2fd24
AE		 5926 /* This makes sub {}; work as expected. */
5927 if (block->op_type == OP_STUB) {
1496a290 5928 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 5929#ifdef PERL_MAD
5930 op_getmad(block,newblock,'B');
5931#else
09c2fd24 5932 op_free(block);
eb8433b7
NC		 5933#endif
5934 block = newblock;
09c2fd24 5935 }
7e5d8ed2
DM		 5936 else
5937 block->op_attached = 1;
7766f137
GS		 5938 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5939 }
5940 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5941 OpREFCNT_set(CvROOT(cv), 1);
5942 CvSTART(cv) = LINKLIST(CvROOT(cv));
5943 CvROOT(cv)->op_next = 0;
a2efc822 5944 CALL_PEEP(CvSTART(cv));
7766f137
GS		 5945
5946 /* now that optimizer has done its work, adjust pad values */
54310121 5947
dd2155a4
DM		 5948 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5949
5950 if (CvCLONE(cv)) {
beab0874
JT		 5951 assert(!CvCONST(cv));
5952 if (ps && !*ps && op_const_sv(block, cv))
5953 CvCONST_on(cv);
a0d0e21e 5954 }
79072805 5955
ed4a8a9b 5956 if (has_name) {
3280af22 5957 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
c4420975 5958 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 5959 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5960 GV_ADDMULTI, SVt_PVHV);
44a8e56a 5961 HV *hv;
b081dd7e
NC		 5962 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
5963 CopFILE(PL_curcop),
5964 (long)PL_subline,
5965 (long)CopLINE(PL_curcop));
bd61b366 5966 gv_efullname3(tmpstr, gv, NULL);
04fe65b0
RGS		 5967 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5968 SvCUR(tmpstr), sv, 0);
44a8e56a 5969 hv = GvHVn(db_postponed);
f4431c56 5970 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
551405c4
AL		 5971 CV * const pcv = GvCV(db_postponed);
5972 if (pcv) {
5973 dSP;
5974 PUSHMARK(SP);
5975 XPUSHs(tmpstr);
5976 PUTBACK;
ad64d0ec 5977 call_sv(MUTABLE_SV(pcv), G_DISCARD);
551405c4 5978 }
44a8e56a 5979 }
5980 }
79072805 5981
13765c85 5982 if (name && ! (PL_parser && PL_parser->error_count))
0cd10f52 5983 process_special_blocks(name, gv, cv);
33fb7a6e 5984 }
ed094faf 5985
33fb7a6e 5986 done:
53a7735b
DM		 5987 if (PL_parser)
5988 PL_parser->copline = NOLINE;
33fb7a6e
NC		 5989 LEAVE_SCOPE(floor);
5990 return cv;
5991}
ed094faf 5992
33fb7a6e
NC		 5993STATIC void
5994S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5995 CV *const cv)
5996{
5997 const char *const colon = strrchr(fullname,':');
5998 const char *const name = colon ? colon + 1 : fullname;
5999
7918f24d
NC		 6000 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6001
33fb7a6e 6002 if (*name == 'B') {
6952d67e 6003 if (strEQ(name, "BEGIN")) {
6867be6d 6004 const I32 oldscope = PL_scopestack_ix;
28757baa 6005 ENTER;
57843af0
GS		 6006 SAVECOPFILE(&PL_compiling);
6007 SAVECOPLINE(&PL_compiling);
28757baa 6008
a58fb6f9 6009 DEBUG_x( dump_sub(gv) );
ad64d0ec 6010 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
ea2f84a3 6011 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 6012 call_list(oldscope, PL_beginav);
a6006777 6013
3280af22 6014 PL_curcop = &PL_compiling;
623e6609 6015 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 6016 LEAVE;
6017 }
33fb7a6e
NC		 6018 else
6019 return;
6020 } else {
6021 if (*name == 'E') {
6022 if strEQ(name, "END") {
a58fb6f9 6023 DEBUG_x( dump_sub(gv) );
ad64d0ec 6024 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
33fb7a6e
NC		 6025 } else
6026 return;
6027 } else if (*name == 'U') {
6028 if (strEQ(name, "UNITCHECK")) {
6029 /* It's never too late to run a unitcheck block */
ad64d0ec 6030 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
33fb7a6e
NC		 6031 }
6032 else
6033 return;
6034 } else if (*name == 'C') {
6035 if (strEQ(name, "CHECK")) {
a2a5de95
NC		 6036 if (PL_main_start)
6037 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6038 "Too late to run CHECK block");
ad64d0ec 6039 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
33fb7a6e
NC		 6040 }
6041 else
6042 return;
6043 } else if (*name == 'I') {
6044 if (strEQ(name, "INIT")) {
a2a5de95
NC		 6045 if (PL_main_start)
6046 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6047 "Too late to run INIT block");
ad64d0ec 6048 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
33fb7a6e
NC		 6049 }
6050 else
6051 return;
6052 } else
6053 return;
a58fb6f9 6054 DEBUG_x( dump_sub(gv) );
33fb7a6e 6055 GvCV(gv) = 0; /* cv has been hijacked */
79072805 6056 }
79072805
LW		 6057}
6058
954c1994
GS		 6059/*
6060=for apidoc newCONSTSUB
6061
6062Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6063eligible for inlining at compile-time.
6064
99ab892b
NC		 6065Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6066which won't be called if used as a destructor, but will suppress the overhead
6067of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6068compile time.)
6069
954c1994
GS		 6070=cut
6071*/
6072
beab0874 6073CV *
e1ec3a88 6074Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5476c433 6075{
27da23d5 6076 dVAR;
beab0874 6077 CV* cv;
cbf82dd0 6078#ifdef USE_ITHREADS
54d012c6 6079 const char *const file = CopFILE(PL_curcop);
cbf82dd0
NC		 6080#else
6081 SV *const temp_sv = CopFILESV(PL_curcop);
def18e4c 6082 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
cbf82dd0 6083#endif
5476c433 6084
11faa288 6085 ENTER;
11faa288 6086
401667e9
DM		 6087 if (IN_PERL_RUNTIME) {
6088 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6089 * an op shared between threads. Use a non-shared COP for our
6090 * dirty work */
6091 SAVEVPTR(PL_curcop);
6092 PL_curcop = &PL_compiling;
6093 }
f4dd75d9 6094 SAVECOPLINE(PL_curcop);
53a7735b 6095 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 6096
6097 SAVEHINTS();
3280af22 6098 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 6099
6100 if (stash) {
6101 SAVESPTR(PL_curstash);
6102 SAVECOPSTASH(PL_curcop);
6103 PL_curstash = stash;
05ec9bb3 6104 CopSTASH_set(PL_curcop,stash);
11faa288 6105 }
5476c433 6106
cbf82dd0
NC		 6107 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6108 and so doesn't get free()d. (It's expected to be from the C pre-
6109 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee 6110 and we need it to get freed. */
54d012c6
NC		 6111 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6112 XS_DYNAMIC_FILENAME);
beab0874
JT		 6113 CvXSUBANY(cv).any_ptr = sv;
6114 CvCONST_on(cv);
5476c433 6115
65e66c80 6116#ifdef USE_ITHREADS
02f28d44
MHM		 6117 if (stash)
6118 CopSTASH_free(PL_curcop);
65e66c80 6119#endif
11faa288 6120 LEAVE;
beab0874
JT		 6121
6122 return cv;
5476c433
JD		 6123}
6124
77004dee
NC		 6125CV *
6126Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6127 const char *const filename, const char *const proto,
6128 U32 flags)
6129{
6130 CV *cv = newXS(name, subaddr, filename);
6131
7918f24d
NC		 6132 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6133
77004dee
NC		 6134 if (flags & XS_DYNAMIC_FILENAME) {
6135 /* We need to "make arrangements" (ie cheat) to ensure that the
6136 filename lasts as long as the PVCV we just created, but also doesn't
6137 leak */
6138 STRLEN filename_len = strlen(filename);
6139 STRLEN proto_and_file_len = filename_len;
6140 char *proto_and_file;
6141 STRLEN proto_len;
6142
6143 if (proto) {
6144 proto_len = strlen(proto);
6145 proto_and_file_len += proto_len;
6146
6147 Newx(proto_and_file, proto_and_file_len + 1, char);
6148 Copy(proto, proto_and_file, proto_len, char);
6149 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6150 } else {
6151 proto_len = 0;
6152 proto_and_file = savepvn(filename, filename_len);
6153 }
6154
6155 /* This gets free()d. :-) */
ad64d0ec 6156 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
77004dee
NC		 6157 SV_HAS_TRAILING_NUL);
6158 if (proto) {
6159 /* This gives us the correct prototype, rather than one with the
6160 file name appended. */
6161 SvCUR_set(cv, proto_len);
6162 } else {
6163 SvPOK_off(cv);
6164 }
81a2b3b6 6165 CvFILE(cv) = proto_and_file + proto_len;
77004dee 6166 } else {
ad64d0ec 6167 sv_setpv(MUTABLE_SV(cv), proto);
77004dee
NC		 6168 }
6169 return cv;
6170}
6171
954c1994
GS		 6172/*
6173=for apidoc U||newXS
6174
77004dee
NC		 6175Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6176static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 6177
6178=cut
6179*/
6180
57d3b86d 6181CV *
bfed75c6 6182Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 6183{
97aff369 6184 dVAR;
666ea192
JH		 6185 GV * const gv = gv_fetchpv(name ? name :
6186 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6187 GV_ADDMULTI, SVt_PVCV);
79072805 6188 register CV *cv;
44a8e56a 6189
7918f24d
NC		 6190 PERL_ARGS_ASSERT_NEWXS;
6191
1ecdd9a8
HS		 6192 if (!subaddr)
6193 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6194
601f1833 6195 if ((cv = (name ? GvCV(gv) : NULL))) {
44a8e56a 6196 if (GvCVGEN(gv)) {
6197 /* just a cached method */
6198 SvREFCNT_dec(cv);
601f1833 6199 cv = NULL;
44a8e56a 6200 }
6201 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6202 /* already defined (or promised) */
1df70142 6203 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
66a1b24b
AL		 6204 if (ckWARN(WARN_REDEFINE)) {
6205 GV * const gvcv = CvGV(cv);
6206 if (gvcv) {
6207 HV * const stash = GvSTASH(gvcv);
6208 if (stash) {
8b38226b
AL		 6209 const char *redefined_name = HvNAME_get(stash);
6210 if ( strEQ(redefined_name,"autouse") ) {
66a1b24b 6211 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 6212 if (PL_parser && PL_parser->copline != NOLINE)
6213 CopLINE_set(PL_curcop, PL_parser->copline);
66a1b24b 6214 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 6215 CvCONST(cv) ? "Constant subroutine %s redefined"
6216 : "Subroutine %s redefined"
6217 ,name);
66a1b24b
AL		 6218 CopLINE_set(PL_curcop, oldline);
6219 }
6220 }
6221 }
a0d0e21e
LW		 6222 }
6223 SvREFCNT_dec(cv);
601f1833 6224 cv = NULL;
79072805 6225 }
79072805 6226 }
44a8e56a 6227
6228 if (cv) /* must reuse cv if autoloaded */
6229 cv_undef(cv);
a0d0e21e 6230 else {
ea726b52 6231 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
44a8e56a 6232 if (name) {
6233 GvCV(gv) = cv;
6234 GvCVGEN(gv) = 0;
e1a479c5 6235 mro_method_changed_in(GvSTASH(gv)); /* newXS */
44a8e56a 6236 }
a0d0e21e 6237 }
803f2748
DM		 6238 if (!name)
6239 CvANON_on(cv);
b3f91e91 6240 CvGV_set(cv, gv);
b195d487 6241 (void)gv_fetchfile(filename);
dd374669 6242 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 6243 an external constant string */
d04ba589 6244 CvISXSUB_on(cv);
a0d0e21e 6245 CvXSUB(cv) = subaddr;
44a8e56a 6246
33fb7a6e
NC		 6247 if (name)
6248 process_special_blocks(name, gv, cv);
44a8e56a 6249
a0d0e21e 6250 return cv;
79072805
LW		 6251}
6252
eb8433b7
NC		 6253#ifdef PERL_MAD
6254OP *
6255#else
79072805 6256void
eb8433b7 6257#endif
864dbfa3 6258Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 6259{
97aff369 6260 dVAR;
79072805 6261 register CV *cv;
eb8433b7
NC		 6262#ifdef PERL_MAD
6263 OP* pegop = newOP(OP_NULL, 0);
6264#endif
79072805 6265
0bd48802 6266 GV * const gv = o
f776e3cd 6267 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 6268 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 6269
a5f75d66 6270 GvMULTI_on(gv);
155aba94 6271 if ((cv = GvFORM(gv))) {
599cee73 6272 if (ckWARN(WARN_REDEFINE)) {
6867be6d 6273 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 6274 if (PL_parser && PL_parser->copline != NOLINE)
6275 CopLINE_set(PL_curcop, PL_parser->copline);
ee6d2783
NC		 6276 if (o) {
6277 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6278 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6279 } else {
6280 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6281 "Format STDOUT redefined");
6282 }
57843af0 6283 CopLINE_set(PL_curcop, oldline);
79072805 6284 }
8990e307 6285 SvREFCNT_dec(cv);
79072805 6286 }
3280af22 6287 cv = PL_compcv;
79072805 6288 GvFORM(gv) = cv;
b3f91e91 6289 CvGV_set(cv, gv);
a636914a 6290 CvFILE_set_from_cop(cv, PL_curcop);
79072805 6291
a0d0e21e 6292
dd2155a4 6293 pad_tidy(padtidy_FORMAT);
79072805 6294 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 6295 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6296 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 6297 CvSTART(cv) = LINKLIST(CvROOT(cv));
6298 CvROOT(cv)->op_next = 0;
a2efc822 6299 CALL_PEEP(CvSTART(cv));
eb8433b7
NC		 6300#ifdef PERL_MAD
6301 op_getmad(o,pegop,'n');
6302 op_getmad_weak(block, pegop, 'b');
6303#else
11343788 6304 op_free(o);
eb8433b7 6305#endif
53a7735b
DM		 6306 if (PL_parser)
6307 PL_parser->copline = NOLINE;
8990e307 6308 LEAVE_SCOPE(floor);
eb8433b7
NC		 6309#ifdef PERL_MAD
6310 return pegop;
6311#endif
79072805
LW		 6312}
6313
6314OP *
864dbfa3 6315Perl_newANONLIST(pTHX_ OP *o)
79072805 6316{
78c72037 6317 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 6318}
6319
6320OP *
864dbfa3 6321Perl_newANONHASH(pTHX_ OP *o)
79072805 6322{
78c72037 6323 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 6324}
6325
6326OP *
864dbfa3 6327Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 6328{
5f66b61c 6329 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 6330}
6331
6332OP *
6333Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6334{
a0d0e21e 6335 return newUNOP(OP_REFGEN, 0,
09bef843 6336 newSVOP(OP_ANONCODE, 0,
ad64d0ec 6337 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
79072805
LW		 6338}
6339
6340OP *
864dbfa3 6341Perl_oopsAV(pTHX_ OP *o)
79072805 6342{
27da23d5 6343 dVAR;
7918f24d
NC		 6344
6345 PERL_ARGS_ASSERT_OOPSAV;
6346
ed6116ce
LW		 6347 switch (o->op_type) {
6348 case OP_PADSV:
6349 o->op_type = OP_PADAV;
22c35a8c 6350 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 6351 return ref(o, OP_RV2AV);
b2ffa427 6352
ed6116ce 6353 case OP_RV2SV:
79072805 6354 o->op_type = OP_RV2AV;
22c35a8c 6355 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 6356 ref(o, OP_RV2AV);
ed6116ce
LW		 6357 break;
6358
6359 default:
9b387841 6360 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 6361 break;
6362 }
79072805
LW		 6363 return o;
6364}
6365
6366OP *
864dbfa3 6367Perl_oopsHV(pTHX_ OP *o)
79072805 6368{
27da23d5 6369 dVAR;
7918f24d
NC		 6370
6371 PERL_ARGS_ASSERT_OOPSHV;
6372
ed6116ce
LW		 6373 switch (o->op_type) {
6374 case OP_PADSV:
6375 case OP_PADAV:
6376 o->op_type = OP_PADHV;
22c35a8c 6377 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 6378 return ref(o, OP_RV2HV);
ed6116ce
LW		 6379
6380 case OP_RV2SV:
6381 case OP_RV2AV:
79072805 6382 o->op_type = OP_RV2HV;
22c35a8c 6383 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 6384 ref(o, OP_RV2HV);
ed6116ce
LW		 6385 break;
6386
6387 default:
9b387841 6388 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 6389 break;
6390 }
79072805
LW		 6391 return o;
6392}
6393
6394OP *
864dbfa3 6395Perl_newAVREF(pTHX_ OP *o)
79072805 6396{
27da23d5 6397 dVAR;
7918f24d
NC		 6398
6399 PERL_ARGS_ASSERT_NEWAVREF;
6400
ed6116ce
LW		 6401 if (o->op_type == OP_PADANY) {
6402 o->op_type = OP_PADAV;
22c35a8c 6403 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 6404 return o;
ed6116ce 6405 }
a2a5de95 6406 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
d1d15184 6407 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 6408 "Using an array as a reference is deprecated");
a1063b2d 6409 }
79072805
LW		 6410 return newUNOP(OP_RV2AV, 0, scalar(o));
6411}
6412
6413OP *
864dbfa3 6414Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 6415{
82092f1d 6416 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 6417 return newUNOP(OP_NULL, 0, o);
748a9306 6418 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 6419}
6420
6421OP *
864dbfa3 6422Perl_newHVREF(pTHX_ OP *o)
79072805 6423{
27da23d5 6424 dVAR;
7918f24d
NC		 6425
6426 PERL_ARGS_ASSERT_NEWHVREF;
6427
ed6116ce
LW		 6428 if (o->op_type == OP_PADANY) {
6429 o->op_type = OP_PADHV;
22c35a8c 6430 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 6431 return o;
ed6116ce 6432 }
a2a5de95 6433 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
d1d15184 6434 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 6435 "Using a hash as a reference is deprecated");
a1063b2d 6436 }
79072805
LW		 6437 return newUNOP(OP_RV2HV, 0, scalar(o));
6438}
6439
6440OP *
864dbfa3 6441Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 6442{
c07a80fd 6443 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 6444}
6445
6446OP *
864dbfa3 6447Perl_newSVREF(pTHX_ OP *o)
79072805 6448{
27da23d5 6449 dVAR;
7918f24d
NC		 6450
6451 PERL_ARGS_ASSERT_NEWSVREF;
6452
ed6116ce
LW		 6453 if (o->op_type == OP_PADANY) {
6454 o->op_type = OP_PADSV;
22c35a8c 6455 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 6456 return o;
ed6116ce 6457 }
79072805
LW		 6458 return newUNOP(OP_RV2SV, 0, scalar(o));
6459}
6460
61b743bb
DM		 6461/* Check routines. See the comments at the top of this file for details
6462 * on when these are called */
79072805
LW		 6463
6464OP *
cea2e8a9 6465Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 6466{
7918f24d
NC		 6467 PERL_ARGS_ASSERT_CK_ANONCODE;
6468
dd2155a4 6469 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
eb8433b7 6470 if (!PL_madskills)
1d866c12 6471 cSVOPo->op_sv = NULL;
5dc0d613 6472 return o;
5f05dabc 6473}
6474
6475OP *
cea2e8a9 6476Perl_ck_bitop(pTHX_ OP *o)
55497cff 6477{
97aff369 6478 dVAR;
7918f24d
NC		 6479
6480 PERL_ARGS_ASSERT_CK_BITOP;
6481
276b2a0c
RGS		 6482#define OP_IS_NUMCOMPARE(op) \
6483 ((op) == OP_LT || (op) == OP_I_LT || \
6484 (op) == OP_GT || (op) == OP_I_GT || \
6485 (op) == OP_LE || (op) == OP_I_LE || \
6486 (op) == OP_GE || (op) == OP_I_GE || \
6487 (op) == OP_EQ || (op) == OP_I_EQ || \
6488 (op) == OP_NE || (op) == OP_I_NE || \
6489 (op) == OP_NCMP || (op) == OP_I_NCMP)
d5ec2987 6490 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 6491 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6492 && (o->op_type == OP_BIT_OR
6493 || o->op_type == OP_BIT_AND
6494 || o->op_type == OP_BIT_XOR))
276b2a0c 6495 {
1df70142
AL		 6496 const OP * const left = cBINOPo->op_first;
6497 const OP * const right = left->op_sibling;
96a925ab
YST		 6498 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6499 (left->op_flags & OPf_PARENS) == 0) ||
6500 (OP_IS_NUMCOMPARE(right->op_type) &&
6501 (right->op_flags & OPf_PARENS) == 0))
a2a5de95
NC		 6502 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6503 "Possible precedence problem on bitwise %c operator",
6504 o->op_type == OP_BIT_OR ? '|'
6505 : o->op_type == OP_BIT_AND ? '&' : '^'
6506 );
276b2a0c 6507 }
5dc0d613 6508 return o;
55497cff 6509}
6510
6511OP *
cea2e8a9 6512Perl_ck_concat(pTHX_ OP *o)
79072805 6513{
0bd48802 6514 const OP * const kid = cUNOPo->op_first;
7918f24d
NC		 6515
6516 PERL_ARGS_ASSERT_CK_CONCAT;
96a5add6 6517 PERL_UNUSED_CONTEXT;
7918f24d 6518
df91b2c5
AE		 6519 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6520 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 6521 o->op_flags |= OPf_STACKED;
11343788 6522 return o;
79072805
LW		 6523}
6524
6525OP *
cea2e8a9 6526Perl_ck_spair(pTHX_ OP *o)
79072805 6527{
27da23d5 6528 dVAR;
7918f24d
NC		 6529
6530 PERL_ARGS_ASSERT_CK_SPAIR;
6531
11343788 6532 if (o->op_flags & OPf_KIDS) {
79072805 6533 OP* newop;
a0d0e21e 6534 OP* kid;
6867be6d 6535 const OPCODE type = o->op_type;
5dc0d613 6536 o = modkids(ck_fun(o), type);
11343788 6537 kid = cUNOPo->op_first;
a0d0e21e 6538 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 6539 if (newop) {
6540 const OPCODE type = newop->op_type;
6541 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6542 type == OP_PADAV || type == OP_PADHV ||
6543 type == OP_RV2AV || type == OP_RV2HV)
6544 return o;
a0d0e21e 6545 }
eb8433b7
NC		 6546#ifdef PERL_MAD
6547 op_getmad(kUNOP->op_first,newop,'K');
6548#else
a0d0e21e 6549 op_free(kUNOP->op_first);
eb8433b7 6550#endif
a0d0e21e
LW		 6551 kUNOP->op_first = newop;
6552 }
22c35a8c 6553 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 6554 return ck_fun(o);
a0d0e21e
LW		 6555}
6556
6557OP *
cea2e8a9 6558Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 6559{
7918f24d
NC		 6560 PERL_ARGS_ASSERT_CK_DELETE;
6561
11343788 6562 o = ck_fun(o);
5dc0d613 6563 o->op_private = 0;
11343788 6564 if (o->op_flags & OPf_KIDS) {
551405c4 6565 OP * const kid = cUNOPo->op_first;
01020589
GS		 6566 switch (kid->op_type) {
6567 case OP_ASLICE:
6568 o->op_flags |= OPf_SPECIAL;
6569 /* FALL THROUGH */
6570 case OP_HSLICE:
5dc0d613 6571 o->op_private |= OPpSLICE;
01020589
GS		 6572 break;
6573 case OP_AELEM:
6574 o->op_flags |= OPf_SPECIAL;
6575 /* FALL THROUGH */
6576 case OP_HELEM:
6577 break;
6578 default:
6579 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 6580 OP_DESC(o));
01020589 6581 }
7332a6c4
VP		 6582 if (kid->op_private & OPpLVAL_INTRO)
6583 o->op_private |= OPpLVAL_INTRO;
93c66552 6584 op_null(kid);
79072805 6585 }
11343788 6586 return o;
79072805
LW		 6587}
6588
6589OP *
96e176bf
CL		 6590Perl_ck_die(pTHX_ OP *o)
6591{
7918f24d
NC		 6592 PERL_ARGS_ASSERT_CK_DIE;
6593
96e176bf
CL		 6594#ifdef VMS
6595 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6596#endif
6597 return ck_fun(o);
6598}
6599
6600OP *
cea2e8a9 6601Perl_ck_eof(pTHX_ OP *o)
79072805 6602{
97aff369 6603 dVAR;
79072805 6604
7918f24d
NC		 6605 PERL_ARGS_ASSERT_CK_EOF;
6606
11343788
MB		 6607 if (o->op_flags & OPf_KIDS) {
6608 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 6609 OP * const newop
6610 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 6611#ifdef PERL_MAD
6612 op_getmad(o,newop,'O');
6613#else
11343788 6614 op_free(o);
eb8433b7
NC		 6615#endif
6616 o = newop;
8990e307 6617 }
11343788 6618 return ck_fun(o);
79072805 6619 }
11343788 6620 return o;
79072805
LW		 6621}
6622
6623OP *
cea2e8a9 6624Perl_ck_eval(pTHX_ OP *o)
79072805 6625{
27da23d5 6626 dVAR;
7918f24d
NC		 6627
6628 PERL_ARGS_ASSERT_CK_EVAL;
6629
3280af22 6630 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6631 if (o->op_flags & OPf_KIDS) {
46c461b5 6632 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 6633
93a17b20 6634 if (!kid) {
11343788 6635 o->op_flags &= ~OPf_KIDS;
93c66552 6636 op_null(o);
79072805 6637 }
b14574b4 6638 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 6639 LOGOP *enter;
eb8433b7 6640#ifdef PERL_MAD
1d866c12 6641 OP* const oldo = o;
eb8433b7 6642#endif
79072805 6643
11343788 6644 cUNOPo->op_first = 0;
eb8433b7 6645#ifndef PERL_MAD
11343788 6646 op_free(o);
eb8433b7 6647#endif
79072805 6648
b7dc083c 6649 NewOp(1101, enter, 1, LOGOP);
79072805 6650 enter->op_type = OP_ENTERTRY;
22c35a8c 6651 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 6652 enter->op_private = 0;
6653
6654 /* establish postfix order */
6655 enter->op_next = (OP*)enter;
6656
11343788
MB		 6657 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6658 o->op_type = OP_LEAVETRY;
22c35a8c 6659 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 6660 enter->op_other = o;
eb8433b7 6661 op_getmad(oldo,o,'O');
11343788 6662 return o;
79072805 6663 }
b5c19bd7 6664 else {
473986ff 6665 scalar((OP*)kid);
b5c19bd7
DM		 6666 PL_cv_has_eval = 1;
6667 }
79072805
LW		 6668 }
6669 else {
eb8433b7 6670#ifdef PERL_MAD
1d866c12 6671 OP* const oldo = o;
eb8433b7 6672#else
11343788 6673 op_free(o);
eb8433b7 6674#endif
54b9620d 6675 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
eb8433b7 6676 op_getmad(oldo,o,'O');
79072805 6677 }
3280af22 6678 o->op_targ = (PADOFFSET)PL_hints;
7168684c 6679 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
996c9baa
VP		 6680 /* Store a copy of %^H that pp_entereval can pick up. */
6681 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
ad64d0ec 6682 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
0d863452
RH		 6683 cUNOPo->op_first->op_sibling = hhop;
6684 o->op_private |= OPpEVAL_HAS_HH;
6685 }
11343788 6686 return o;
79072805
LW		 6687}
6688
6689OP *
d98f61e7
GS		 6690Perl_ck_exit(pTHX_ OP *o)
6691{
7918f24d
NC		 6692 PERL_ARGS_ASSERT_CK_EXIT;
6693
d98f61e7 6694#ifdef VMS
551405c4 6695 HV * const table = GvHV(PL_hintgv);
d98f61e7 6696 if (table) {
a4fc7abc 6697 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 6698 if (svp && *svp && SvTRUE(*svp))
6699 o->op_private |= OPpEXIT_VMSISH;
6700 }
96e176bf 6701 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 6702#endif
6703 return ck_fun(o);
6704}
6705
6706OP *
cea2e8a9 6707Perl_ck_exec(pTHX_ OP *o)
79072805 6708{
7918f24d
NC		 6709 PERL_ARGS_ASSERT_CK_EXEC;
6710
11343788 6711 if (o->op_flags & OPf_STACKED) {
6867be6d 6712 OP *kid;
11343788
MB		 6713 o = ck_fun(o);
6714 kid = cUNOPo->op_first->op_sibling;
8990e307 6715 if (kid->op_type == OP_RV2GV)
93c66552 6716 op_null(kid);
79072805 6717 }
463ee0b2 6718 else
11343788
MB		 6719 o = listkids(o);
6720 return o;
79072805
LW		 6721}
6722
6723OP *
cea2e8a9 6724Perl_ck_exists(pTHX_ OP *o)
5f05dabc 6725{
97aff369 6726 dVAR;
7918f24d
NC		 6727
6728 PERL_ARGS_ASSERT_CK_EXISTS;
6729
5196be3e
MB		 6730 o = ck_fun(o);
6731 if (o->op_flags & OPf_KIDS) {
46c461b5 6732 OP * const kid = cUNOPo->op_first;
afebc493
GS		 6733 if (kid->op_type == OP_ENTERSUB) {
6734 (void) ref(kid, o->op_type);
13765c85
DM		 6735 if (kid->op_type != OP_RV2CV
6736 && !(PL_parser && PL_parser->error_count))
afebc493 6737 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 6738 OP_DESC(o));
afebc493
GS		 6739 o->op_private |= OPpEXISTS_SUB;
6740 }
6741 else if (kid->op_type == OP_AELEM)
01020589
GS		 6742 o->op_flags |= OPf_SPECIAL;
6743 else if (kid->op_type != OP_HELEM)
b0fdf69e 6744 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
53e06cf0 6745 OP_DESC(o));
93c66552 6746 op_null(kid);
5f05dabc 6747 }
5196be3e 6748 return o;
5f05dabc 6749}
6750
79072805 6751OP *
cea2e8a9 6752Perl_ck_rvconst(pTHX_ register OP *o)
79072805 6753{
27da23d5 6754 dVAR;
0bd48802 6755 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 6756
7918f24d
NC		 6757 PERL_ARGS_ASSERT_CK_RVCONST;
6758
3280af22 6759 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 6760 if (o->op_type == OP_RV2CV)
6761 o->op_private &= ~1;
6762
79072805 6763 if (kid->op_type == OP_CONST) {
44a8e56a 6764 int iscv;
6765 GV *gv;
504618e9 6766 SV * const kidsv = kid->op_sv;
44a8e56a 6767
779c5bc9
GS		 6768 /* Is it a constant from cv_const_sv()? */
6769 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 6770 SV * const rsv = SvRV(kidsv);
42d0e0b7 6771 const svtype type = SvTYPE(rsv);
bd61b366 6772 const char *badtype = NULL;
779c5bc9
GS		 6773
6774 switch (o->op_type) {
6775 case OP_RV2SV:
42d0e0b7 6776 if (type > SVt_PVMG)
779c5bc9
GS		 6777 badtype = "a SCALAR";
6778 break;
6779 case OP_RV2AV:
42d0e0b7 6780 if (type != SVt_PVAV)
779c5bc9
GS		 6781 badtype = "an ARRAY";
6782 break;
6783 case OP_RV2HV:
42d0e0b7 6784 if (type != SVt_PVHV)
779c5bc9 6785 badtype = "a HASH";
779c5bc9
GS		 6786 break;
6787 case OP_RV2CV:
42d0e0b7 6788 if (type != SVt_PVCV)
779c5bc9
GS		 6789 badtype = "a CODE";
6790 break;
6791 }
6792 if (badtype)
cea2e8a9 6793 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 6794 return o;
6795 }
ce10b5d1 6796 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 6797 const char *badthing;
5dc0d613 6798 switch (o->op_type) {
44a8e56a 6799 case OP_RV2SV:
6800 badthing = "a SCALAR";
6801 break;
6802 case OP_RV2AV:
6803 badthing = "an ARRAY";
6804 break;
6805 case OP_RV2HV:
6806 badthing = "a HASH";
6807 break;
5f66b61c
AL		 6808 default:
6809 badthing = NULL;
6810 break;
44a8e56a 6811 }
6812 if (badthing)
1c846c1f 6813 Perl_croak(aTHX_
95b63a38 6814 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 6815 SVfARG(kidsv), badthing);
44a8e56a 6816 }
93233ece
CS		 6817 /*
6818 * This is a little tricky. We only want to add the symbol if we
6819 * didn't add it in the lexer. Otherwise we get duplicate strict
6820 * warnings. But if we didn't add it in the lexer, we must at
6821 * least pretend like we wanted to add it even if it existed before,
6822 * or we get possible typo warnings. OPpCONST_ENTERED says
6823 * whether the lexer already added THIS instance of this symbol.
6824 */
5196be3e 6825 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 6826 do {
7a5fd60d 6827 gv = gv_fetchsv(kidsv,
748a9306 6828 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 6829 iscv
6830 ? SVt_PVCV
11343788 6831 : o->op_type == OP_RV2SV
a0d0e21e 6832 ? SVt_PV
11343788 6833 : o->op_type == OP_RV2AV
a0d0e21e 6834 ? SVt_PVAV
11343788 6835 : o->op_type == OP_RV2HV
a0d0e21e
LW		 6836 ? SVt_PVHV
6837 : SVt_PVGV);
93233ece
CS		 6838 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6839 if (gv) {
6840 kid->op_type = OP_GV;
6841 SvREFCNT_dec(kid->op_sv);
350de78d 6842#ifdef USE_ITHREADS
638eceb6 6843 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 6844 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 6845 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 6846 GvIN_PAD_on(gv);
ad64d0ec 6847 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
350de78d 6848#else
b37c2d43 6849 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 6850#endif
23f1ca44 6851 kid->op_private = 0;
76cd736e 6852 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 6853 }
79072805 6854 }
11343788 6855 return o;
79072805
LW		 6856}
6857
6858OP *
cea2e8a9 6859Perl_ck_ftst(pTHX_ OP *o)
79072805 6860{
27da23d5 6861 dVAR;
6867be6d 6862 const I32 type = o->op_type;
79072805 6863
7918f24d
NC		 6864 PERL_ARGS_ASSERT_CK_FTST;
6865
d0dca557 6866 if (o->op_flags & OPf_REF) {
6f207bd3 6867 NOOP;
d0dca557
JD		 6868 }
6869 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 6870 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 6871 const OPCODE kidtype = kid->op_type;
79072805 6872
1496a290 6873 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 6874 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 6875 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 6876#ifdef PERL_MAD
6877 op_getmad(o,newop,'O');
6878#else
11343788 6879 op_free(o);
eb8433b7 6880#endif
1d866c12 6881 return newop;
79072805 6882 }
6ecf81d6 6883 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
1af34c76 6884 o->op_private |= OPpFT_ACCESS;
1496a290
AL		 6885 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6886 && kidtype != OP_STAT && kidtype != OP_LSTAT)
fbb0b3b3 6887 o->op_private |= OPpFT_STACKED;
79072805
LW		 6888 }
6889 else {
eb8433b7 6890#ifdef PERL_MAD
1d866c12 6891 OP* const oldo = o;
eb8433b7 6892#else
11343788 6893 op_free(o);
eb8433b7 6894#endif
79072805 6895 if (type == OP_FTTTY)
8fde6460 6896 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 6897 else
d0dca557 6898 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 6899 op_getmad(oldo,o,'O');
79072805 6900 }
11343788 6901 return o;
79072805
LW		 6902}
6903
6904OP *
cea2e8a9 6905Perl_ck_fun(pTHX_ OP *o)
79072805 6906{
97aff369 6907 dVAR;
6867be6d 6908 const int type = o->op_type;
22c35a8c 6909 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 6910
7918f24d
NC		 6911 PERL_ARGS_ASSERT_CK_FUN;
6912
11343788 6913 if (o->op_flags & OPf_STACKED) {
79072805
LW		 6914 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6915 oa &= ~OA_OPTIONAL;
6916 else
11343788 6917 return no_fh_allowed(o);
79072805
LW		 6918 }
6919
11343788 6920 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 6921 OP **tokid = &cLISTOPo->op_first;
6922 register OP *kid = cLISTOPo->op_first;
6923 OP *sibl;
6924 I32 numargs = 0;
6925
8990e307 6926 if (kid->op_type == OP_PUSHMARK ||
155aba94 6927 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 6928 {
79072805
LW		 6929 tokid = &kid->op_sibling;
6930 kid = kid->op_sibling;
6931 }
22c35a8c 6932 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 6933 *tokid = kid = newDEFSVOP();
79072805
LW		 6934
6935 while (oa && kid) {
6936 numargs++;
6937 sibl = kid->op_sibling;
eb8433b7
NC		 6938#ifdef PERL_MAD
6939 if (!sibl && kid->op_type == OP_STUB) {
6940 numargs--;
6941 break;
6942 }
6943#endif
79072805
LW		 6944 switch (oa & 7) {
6945 case OA_SCALAR:
62c18ce2
GS		 6946 /* list seen where single (scalar) arg expected? */
6947 if (numargs == 1 && !(oa >> 4)
6948 && kid->op_type == OP_LIST && type != OP_SCALAR)
6949 {
6950 return too_many_arguments(o,PL_op_desc[type]);
6951 }
79072805
LW		 6952 scalar(kid);
6953 break;
6954 case OA_LIST:
6955 if (oa < 16) {
6956 kid = 0;
6957 continue;
6958 }
6959 else
6960 list(kid);
6961 break;
6962 case OA_AVREF:
936edb8b 6963 if ((type == OP_PUSH || type == OP_UNSHIFT)
a2a5de95
NC		 6964 && !kid->op_sibling)
6965 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6966 "Useless use of %s with no values",
6967 PL_op_desc[type]);
b2ffa427 6968
79072805 6969 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6970 (kid->op_private & OPpCONST_BARE))
6971 {
551405c4 6972 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 6973 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
d1d15184 6974 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 6975 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6976 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6977#ifdef PERL_MAD
6978 op_getmad(kid,newop,'K');
6979#else
79072805 6980 op_free(kid);
eb8433b7 6981#endif
79072805
LW		 6982 kid = newop;
6983 kid->op_sibling = sibl;
6984 *tokid = kid;
6985 }
8990e307 6986 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 6987 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 6988 mod(kid, type);
79072805
LW		 6989 break;
6990 case OA_HVREF:
6991 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6992 (kid->op_private & OPpCONST_BARE))
6993 {
551405c4 6994 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 6995 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
d1d15184 6996 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 6997 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6998 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6999#ifdef PERL_MAD
7000 op_getmad(kid,newop,'K');
7001#else
79072805 7002 op_free(kid);
eb8433b7 7003#endif
79072805
LW		 7004 kid = newop;
7005 kid->op_sibling = sibl;
7006 *tokid = kid;
7007 }
8990e307 7008 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 7009 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 7010 mod(kid, type);
79072805
LW		 7011 break;
7012 case OA_CVREF:
7013 {
551405c4 7014 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 7015 kid->op_sibling = 0;
7016 linklist(kid);
7017 newop->op_next = newop;
7018 kid = newop;
7019 kid->op_sibling = sibl;
7020 *tokid = kid;
7021 }
7022 break;
7023 case OA_FILEREF:
c340be78 7024 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 7025 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 7026 (kid->op_private & OPpCONST_BARE))
7027 {
0bd48802 7028 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 7029 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 7030 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 7031 kid == cLISTOPo->op_last)
364daeac 7032 cLISTOPo->op_last = newop;
eb8433b7
NC		 7033#ifdef PERL_MAD
7034 op_getmad(kid,newop,'K');
7035#else
79072805 7036 op_free(kid);
eb8433b7 7037#endif
79072805
LW		 7038 kid = newop;
7039 }
1ea32a52
GS		 7040 else if (kid->op_type == OP_READLINE) {
7041 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 7042 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 7043 }
79072805 7044 else {
35cd451c 7045 I32 flags = OPf_SPECIAL;
a6c40364 7046 I32 priv = 0;
2c8ac474
GS		 7047 PADOFFSET targ = 0;
7048
35cd451c 7049 /* is this op a FH constructor? */
853846ea 7050 if (is_handle_constructor(o,numargs)) {
bd61b366 7051 const char *name = NULL;
dd2155a4 7052 STRLEN len = 0;
2c8ac474
GS		 7053
7054 flags = 0;
7055 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 7056 * need to "prove" flag does not mean something
7057 * else already - NI-S 1999/05/07
2c8ac474
GS		 7058 */
7059 priv = OPpDEREF;
7060 if (kid->op_type == OP_PADSV) {
f8503592
NC		 7061 SV *const namesv
7062 = PAD_COMPNAME_SV(kid->op_targ);
7063 name = SvPV_const(namesv, len);
2c8ac474
GS		 7064 }
7065 else if (kid->op_type == OP_RV2SV
7066 && kUNOP->op_first->op_type == OP_GV)
7067 {
0bd48802 7068 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 7069 name = GvNAME(gv);
7070 len = GvNAMELEN(gv);
7071 }
afd1915d
GS		 7072 else if (kid->op_type == OP_AELEM
7073 || kid->op_type == OP_HELEM)
7074 {
735fec84 7075 OP *firstop;
551405c4 7076 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 7077 name = NULL;
551405c4 7078 if (op) {
a0714e2c 7079 SV *tmpstr = NULL;
551405c4 7080 const char * const a =
666ea192
JH		 7081 kid->op_type == OP_AELEM ?
7082 "[]" : "{}";
0c4b0a3f
JH		 7083 if (((op->op_type == OP_RV2AV) ||
7084 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 7085 (firstop = ((UNOP*)op)->op_first) &&
7086 (firstop->op_type == OP_GV)) {
0c4b0a3f 7087 /* packagevar $a[] or $h{} */
735fec84 7088 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 7089 if (gv)
7090 tmpstr =
7091 Perl_newSVpvf(aTHX_
7092 "%s%c...%c",
7093 GvNAME(gv),
7094 a[0], a[1]);
7095 }
7096 else if (op->op_type == OP_PADAV
7097 || op->op_type == OP_PADHV) {
7098 /* lexicalvar $a[] or $h{} */
551405c4 7099 const char * const padname =
0c4b0a3f
JH		 7100 PAD_COMPNAME_PV(op->op_targ);
7101 if (padname)
7102 tmpstr =
7103 Perl_newSVpvf(aTHX_
7104 "%s%c...%c",
7105 padname + 1,
7106 a[0], a[1]);
0c4b0a3f
JH		 7107 }
7108 if (tmpstr) {
93524f2b 7109 name = SvPV_const(tmpstr, len);
0c4b0a3f
JH		 7110 sv_2mortal(tmpstr);
7111 }
7112 }
7113 if (!name) {
7114 name = "__ANONIO__";
7115 len = 10;
7116 }
7117 mod(kid, type);
afd1915d 7118 }
2c8ac474
GS		 7119 if (name) {
7120 SV *namesv;
7121 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 7122 namesv = PAD_SVl(targ);
862a34c6 7123 SvUPGRADE(namesv, SVt_PV);
2c8ac474 7124 if (*name != '$')
76f68e9b 7125 sv_setpvs(namesv, "$");
2c8ac474
GS		 7126 sv_catpvn(namesv, name, len);
7127 }
853846ea 7128 }
79072805 7129 kid->op_sibling = 0;
35cd451c 7130 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 7131 kid->op_targ = targ;
7132 kid->op_private |= priv;
79072805
LW		 7133 }
7134 kid->op_sibling = sibl;
7135 *tokid = kid;
7136 }
7137 scalar(kid);
7138 break;
7139 case OA_SCALARREF:
a0d0e21e 7140 mod(scalar(kid), type);
79072805
LW		 7141 break;
7142 }
7143 oa >>= 4;
7144 tokid = &kid->op_sibling;
7145 kid = kid->op_sibling;
7146 }
eb8433b7
NC		 7147#ifdef PERL_MAD
7148 if (kid && kid->op_type != OP_STUB)
7149 return too_many_arguments(o,OP_DESC(o));
7150 o->op_private |= numargs;
7151#else
7152 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 7153 o->op_private |= numargs;
79072805 7154 if (kid)
53e06cf0 7155 return too_many_arguments(o,OP_DESC(o));
eb8433b7 7156#endif
11343788 7157 listkids(o);
79072805 7158 }
22c35a8c 7159 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 7160#ifdef PERL_MAD
c7fe699d 7161 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 7162 op_getmad(o,newop,'O');
c7fe699d 7163 return newop;
c56915e3 7164#else
c7fe699d 7165 /* Ordering of these two is important to keep f_map.t passing. */
11343788 7166 op_free(o);
c7fe699d 7167 return newUNOP(type, 0, newDEFSVOP());
c56915e3 7168#endif
a0d0e21e
LW		 7169 }
7170
79072805
LW		 7171 if (oa) {
7172 while (oa & OA_OPTIONAL)
7173 oa >>= 4;
7174 if (oa && oa != OA_LIST)
53e06cf0 7175 return too_few_arguments(o,OP_DESC(o));
79072805 7176 }
11343788 7177 return o;
79072805
LW		 7178}
7179
7180OP *
cea2e8a9 7181Perl_ck_glob(pTHX_ OP *o)
79072805 7182{
27da23d5 7183 dVAR;
fb73857a 7184 GV *gv;
7185
7918f24d
NC		 7186 PERL_ARGS_ASSERT_CK_GLOB;
7187
649da076 7188 o = ck_fun(o);
1f2bfc8a 7189 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 7190 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 7191
fafc274c 7192 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 7193 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7194 {
5c1737d1 7195 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 7196 }
b1cb66bf 7197
52bb0670 7198#if !defined(PERL_EXTERNAL_GLOB)
72b16652 7199 /* XXX this can be tightened up and made more failsafe. */
f444d496 7200 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 7201 GV *glob_gv;
72b16652 7202 ENTER;
00ca71c1 7203 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
a0714e2c 7204 newSVpvs("File::Glob"), NULL, NULL, NULL);
4984aa34
FC		 7205 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7206 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7207 GvCV(gv) = GvCV(glob_gv);
7208 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7209 GvIMPORTED_CV_on(gv);
7210 }
72b16652
GS		 7211 LEAVE;
7212 }
52bb0670 7213#endif /* PERL_EXTERNAL_GLOB */
72b16652 7214
b9f751c0 7215 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 7216 append_elem(OP_GLOB, o,
80252599 7217 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 7218 o->op_type = OP_LIST;
22c35a8c 7219 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 7220 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 7221 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 7222 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 7223 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 7224 append_elem(OP_LIST, o,
1f2bfc8a
MB		 7225 scalar(newUNOP(OP_RV2CV, 0,
7226 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 7227 o = newUNOP(OP_NULL, 0, ck_subr(o));
7228 o->op_targ = OP_GLOB; /* hint at what it used to be */
7229 return o;
b1cb66bf 7230 }
7231 gv = newGVgen("main");
a0d0e21e 7232 gv_IOadd(gv);
11343788
MB		 7233 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7234 scalarkids(o);
649da076 7235 return o;
79072805
LW		 7236}
7237
7238OP *
cea2e8a9 7239Perl_ck_grep(pTHX_ OP *o)
79072805 7240{
27da23d5 7241 dVAR;
03ca120d 7242 LOGOP *gwop = NULL;
79072805 7243 OP *kid;
6867be6d 7244 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 7245 PADOFFSET offset;
79072805 7246
7918f24d
NC		 7247 PERL_ARGS_ASSERT_CK_GREP;
7248
22c35a8c 7249 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 7250 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 7251
11343788 7252 if (o->op_flags & OPf_STACKED) {
a0d0e21e 7253 OP* k;
11343788 7254 o = ck_sort(o);
f6435df3
GG		 7255 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7256 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7257 return no_fh_allowed(o);
7258 for (k = kid; k; k = k->op_next) {
a0d0e21e
LW		 7259 kid = k;
7260 }
03ca120d 7261 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 7262 kid->op_next = (OP*)gwop;
11343788 7263 o->op_flags &= ~OPf_STACKED;
93a17b20 7264 }
11343788 7265 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 7266 if (type == OP_MAPWHILE)
7267 list(kid);
7268 else
7269 scalar(kid);
11343788 7270 o = ck_fun(o);
13765c85 7271 if (PL_parser && PL_parser->error_count)
11343788 7272 return o;
aeea060c 7273 kid = cLISTOPo->op_first->op_sibling;
79072805 7274 if (kid->op_type != OP_NULL)
cea2e8a9 7275 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 7276 kid = kUNOP->op_first;
7277
03ca120d
MHM		 7278 if (!gwop)
7279 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 7280 gwop->op_type = type;
22c35a8c 7281 gwop->op_ppaddr = PL_ppaddr[type];
11343788 7282 gwop->op_first = listkids(o);
79072805 7283 gwop->op_flags |= OPf_KIDS;
79072805 7284 gwop->op_other = LINKLIST(kid);
79072805 7285 kid->op_next = (OP*)gwop;
f8f98e0a 7286 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
00b1698f 7287 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 7288 o->op_private = gwop->op_private = 0;
7289 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7290 }
7291 else {
7292 o->op_private = gwop->op_private = OPpGREP_LEX;
7293 gwop->op_targ = o->op_targ = offset;
7294 }
79072805 7295
11343788 7296 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 7297 if (!kid || !kid->op_sibling)
53e06cf0 7298 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 7299 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7300 mod(kid, OP_GREPSTART);
7301
79072805
LW		 7302 return (OP*)gwop;
7303}
7304
7305OP *
cea2e8a9 7306Perl_ck_index(pTHX_ OP *o)
79072805 7307{
7918f24d
NC		 7308 PERL_ARGS_ASSERT_CK_INDEX;
7309
11343788
MB		 7310 if (o->op_flags & OPf_KIDS) {
7311 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 7312 if (kid)
7313 kid = kid->op_sibling; /* get past "big" */
79072805 7314 if (kid && kid->op_type == OP_CONST)
2779dcf1 7315 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 7316 }
11343788 7317 return ck_fun(o);
79072805
LW		 7318}
7319
7320OP *
cea2e8a9 7321Perl_ck_lfun(pTHX_ OP *o)
79072805 7322{
6867be6d 7323 const OPCODE type = o->op_type;
7918f24d
NC		 7324
7325 PERL_ARGS_ASSERT_CK_LFUN;
7326
5dc0d613 7327 return modkids(ck_fun(o), type);
79072805
LW		 7328}
7329
7330OP *
cea2e8a9 7331Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 7332{
7918f24d
NC		 7333 PERL_ARGS_ASSERT_CK_DEFINED;
7334
a2a5de95 7335 if ((o->op_flags & OPf_KIDS)) {
d0334bed
GS		 7336 switch (cUNOPo->op_first->op_type) {
7337 case OP_RV2AV:
a8739d98
JH		 7338 /* This is needed for
7339 if (defined %stash::)
7340 to work. Do not break Tk.
7341 */
1c846c1f 7342 break; /* Globals via GV can be undef */
d0334bed
GS		 7343 case OP_PADAV:
7344 case OP_AASSIGN: /* Is this a good idea? */
d1d15184 7345 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7346 "defined(@array) is deprecated");
d1d15184 7347 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7348 "\t(Maybe you should just omit the defined()?)\n");
69794302 7349 break;
d0334bed
GS		 7350 case OP_RV2HV:
7351 case OP_PADHV:
d1d15184 7352 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7353 "defined(%%hash) is deprecated");
d1d15184 7354 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7355 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 7356 break;
7357 default:
7358 /* no warning */
7359 break;
7360 }
69794302
MJD		 7361 }
7362 return ck_rfun(o);
7363}
7364
7365OP *
e4b7ebf3
RGS		 7366Perl_ck_readline(pTHX_ OP *o)
7367{
7918f24d
NC		 7368 PERL_ARGS_ASSERT_CK_READLINE;
7369
e4b7ebf3
RGS		 7370 if (!(o->op_flags & OPf_KIDS)) {
7371 OP * const newop
7372 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7373#ifdef PERL_MAD
7374 op_getmad(o,newop,'O');
7375#else
7376 op_free(o);
7377#endif
7378 return newop;
7379 }
7380 return o;
7381}
7382
7383OP *
cea2e8a9 7384Perl_ck_rfun(pTHX_ OP *o)
8990e307 7385{
6867be6d 7386 const OPCODE type = o->op_type;
7918f24d
NC		 7387
7388 PERL_ARGS_ASSERT_CK_RFUN;
7389
5dc0d613 7390 return refkids(ck_fun(o), type);
8990e307
LW		 7391}
7392
7393OP *
cea2e8a9 7394Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 7395{
7396 register OP *kid;
aeea060c 7397
7918f24d
NC		 7398 PERL_ARGS_ASSERT_CK_LISTIOB;
7399
11343788 7400 kid = cLISTOPo->op_first;
79072805 7401 if (!kid) {
11343788
MB		 7402 o = force_list(o);
7403 kid = cLISTOPo->op_first;
79072805
LW		 7404 }
7405 if (kid->op_type == OP_PUSHMARK)
7406 kid = kid->op_sibling;
11343788 7407 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 7408 kid = kid->op_sibling;
7409 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7410 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 7411 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 7412 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 7413 cLISTOPo->op_first->op_sibling = kid;
7414 cLISTOPo->op_last = kid;
79072805
LW		 7415 kid = kid->op_sibling;
7416 }
7417 }
b2ffa427 7418
79072805 7419 if (!kid)
54b9620d 7420 append_elem(o->op_type, o, newDEFSVOP());
79072805 7421
2de3dbcc 7422 return listkids(o);
bbce6d69 7423}
7424
7425OP *
0d863452
RH		 7426Perl_ck_smartmatch(pTHX_ OP *o)
7427{
97aff369 7428 dVAR;
0d863452
RH		 7429 if (0 == (o->op_flags & OPf_SPECIAL)) {
7430 OP *first = cBINOPo->op_first;
7431 OP *second = first->op_sibling;
7432
7433 /* Implicitly take a reference to an array or hash */
5f66b61c 7434 first->op_sibling = NULL;
0d863452
RH		 7435 first = cBINOPo->op_first = ref_array_or_hash(first);
7436 second = first->op_sibling = ref_array_or_hash(second);
7437
7438 /* Implicitly take a reference to a regular expression */
7439 if (first->op_type == OP_MATCH) {
7440 first->op_type = OP_QR;
7441 first->op_ppaddr = PL_ppaddr[OP_QR];
7442 }
7443 if (second->op_type == OP_MATCH) {
7444 second->op_type = OP_QR;
7445 second->op_ppaddr = PL_ppaddr[OP_QR];
7446 }
7447 }
7448
7449 return o;
7450}
7451
7452
7453OP *
b162f9ea
IZ		 7454Perl_ck_sassign(pTHX_ OP *o)
7455{
3088bf26 7456 dVAR;
1496a290 7457 OP * const kid = cLISTOPo->op_first;
7918f24d
NC		 7458
7459 PERL_ARGS_ASSERT_CK_SASSIGN;
7460
b162f9ea
IZ		 7461 /* has a disposable target? */
7462 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 7463 && !(kid->op_flags & OPf_STACKED)
7464 /* Cannot steal the second time! */
1b438339
GG		 7465 && !(kid->op_private & OPpTARGET_MY)
7466 /* Keep the full thing for madskills */
7467 && !PL_madskills
7468 )
b162f9ea 7469 {
551405c4 7470 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 7471
7472 /* Can just relocate the target. */
2c2d71f5
JH		 7473 if (kkid && kkid->op_type == OP_PADSV
7474 && !(kkid->op_private & OPpLVAL_INTRO))
7475 {
b162f9ea 7476 kid->op_targ = kkid->op_targ;
743e66e6 7477 kkid->op_targ = 0;
b162f9ea
IZ		 7478 /* Now we do not need PADSV and SASSIGN. */
7479 kid->op_sibling = o->op_sibling; /* NULL */
7480 cLISTOPo->op_first = NULL;
7481 op_free(o);
7482 op_free(kkid);
7483 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7484 return kid;
7485 }
7486 }
c5917253
NC		 7487 if (kid->op_sibling) {
7488 OP *kkid = kid->op_sibling;
7489 if (kkid->op_type == OP_PADSV
7490 && (kkid->op_private & OPpLVAL_INTRO)
7491 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7492 const PADOFFSET target = kkid->op_targ;
7493 OP *const other = newOP(OP_PADSV,
7494 kkid->op_flags
7495 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7496 OP *const first = newOP(OP_NULL, 0);
7497 OP *const nullop = newCONDOP(0, first, o, other);
7498 OP *const condop = first->op_next;
7499 /* hijacking PADSTALE for uninitialized state variables */
7500 SvPADSTALE_on(PAD_SVl(target));
7501
7502 condop->op_type = OP_ONCE;
7503 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7504 condop->op_targ = target;
7505 other->op_targ = target;
7506
95562366
NC		 7507 /* Because we change the type of the op here, we will skip the
7508 assinment binop->op_last = binop->op_first->op_sibling; at the
7509 end of Perl_newBINOP(). So need to do it here. */
7510 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7511
c5917253
NC		 7512 return nullop;
7513 }
7514 }
b162f9ea
IZ		 7515 return o;
7516}
7517
7518OP *
cea2e8a9 7519Perl_ck_match(pTHX_ OP *o)
79072805 7520{
97aff369 7521 dVAR;
7918f24d
NC		 7522
7523 PERL_ARGS_ASSERT_CK_MATCH;
7524
0d863452 7525 if (o->op_type != OP_QR && PL_compcv) {
f8f98e0a 7526 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
00b1698f 7527 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 7528 o->op_targ = offset;
7529 o->op_private |= OPpTARGET_MY;
7530 }
7531 }
7532 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7533 o->op_private |= OPpRUNTIME;
11343788 7534 return o;
79072805
LW		 7535}
7536
7537OP *
f5d5a27c
CS		 7538Perl_ck_method(pTHX_ OP *o)
7539{
551405c4 7540 OP * const kid = cUNOPo->op_first;
7918f24d
NC		 7541
7542 PERL_ARGS_ASSERT_CK_METHOD;
7543
f5d5a27c
CS		 7544 if (kid->op_type == OP_CONST) {
7545 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 7546 const char * const method = SvPVX_const(sv);
7547 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 7548 OP *cmop;
1c846c1f 7549 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
a4fc7abc 7550 sv = newSVpvn_share(method, SvCUR(sv), 0);
1c846c1f
NIS		 7551 }
7552 else {
a0714e2c 7553 kSVOP->op_sv = NULL;
1c846c1f 7554 }
f5d5a27c 7555 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 7556#ifdef PERL_MAD
7557 op_getmad(o,cmop,'O');
7558#else
f5d5a27c 7559 op_free(o);
eb8433b7 7560#endif
f5d5a27c
CS		 7561 return cmop;
7562 }
7563 }
7564 return o;
7565}
7566
7567OP *
cea2e8a9 7568Perl_ck_null(pTHX_ OP *o)
79072805 7569{
7918f24d 7570 PERL_ARGS_ASSERT_CK_NULL;
96a5add6 7571 PERL_UNUSED_CONTEXT;
11343788 7572 return o;
79072805
LW		 7573}
7574
7575OP *
16fe6d59
GS		 7576Perl_ck_open(pTHX_ OP *o)
7577{
97aff369 7578 dVAR;
551405c4 7579 HV * const table = GvHV(PL_hintgv);
7918f24d
NC		 7580
7581 PERL_ARGS_ASSERT_CK_OPEN;
7582
16fe6d59 7583 if (table) {
a4fc7abc 7584 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 7585 if (svp && *svp) {
a79b25b7
VP		 7586 STRLEN len = 0;
7587 const char *d = SvPV_const(*svp, len);
7588 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 7589 if (mode & O_BINARY)
7590 o->op_private |= OPpOPEN_IN_RAW;
7591 else if (mode & O_TEXT)
7592 o->op_private |= OPpOPEN_IN_CRLF;
7593 }
7594
a4fc7abc 7595 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 7596 if (svp && *svp) {
a79b25b7
VP		 7597 STRLEN len = 0;
7598 const char *d = SvPV_const(*svp, len);
7599 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 7600 if (mode & O_BINARY)
7601 o->op_private |= OPpOPEN_OUT_RAW;
7602 else if (mode & O_TEXT)
7603 o->op_private |= OPpOPEN_OUT_CRLF;
7604 }
7605 }
8d7403e6
RGS		 7606 if (o->op_type == OP_BACKTICK) {
7607 if (!(o->op_flags & OPf_KIDS)) {
e4b7ebf3
RGS		 7608 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7609#ifdef PERL_MAD
7610 op_getmad(o,newop,'O');
7611#else
8d7403e6 7612 op_free(o);
e4b7ebf3
RGS		 7613#endif
7614 return newop;
8d7403e6 7615 }
16fe6d59 7616 return o;
8d7403e6 7617 }
3b82e551
JH		 7618 {
7619 /* In case of three-arg dup open remove strictness
7620 * from the last arg if it is a bareword. */
551405c4
AL		 7621 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7622 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 7623 OP *oa;
b15aece3 7624 const char *mode;
3b82e551
JH		 7625
7626 if ((last->op_type == OP_CONST) && /* The bareword. */
7627 (last->op_private & OPpCONST_BARE) &&
7628 (last->op_private & OPpCONST_STRICT) &&
7629 (oa = first->op_sibling) && /* The fh. */
7630 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 7631 (oa->op_type == OP_CONST) &&
3b82e551 7632 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 7633 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 7634 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7635 (last == oa->op_sibling)) /* The bareword. */
7636 last->op_private &= ~OPpCONST_STRICT;
7637 }
16fe6d59
GS		 7638 return ck_fun(o);
7639}
7640
7641OP *
cea2e8a9 7642Perl_ck_repeat(pTHX_ OP *o)
79072805 7643{
7918f24d
NC		 7644 PERL_ARGS_ASSERT_CK_REPEAT;
7645
11343788
MB		 7646 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7647 o->op_private |= OPpREPEAT_DOLIST;
7648 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 7649 }
7650 else
11343788
MB		 7651 scalar(o);
7652 return o;
79072805
LW		 7653}
7654
7655OP *
cea2e8a9 7656Perl_ck_require(pTHX_ OP *o)
8990e307 7657{
97aff369 7658 dVAR;
a0714e2c 7659 GV* gv = NULL;
ec4ab249 7660
7918f24d
NC		 7661 PERL_ARGS_ASSERT_CK_REQUIRE;
7662
11343788 7663 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 7664 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 7665
7666 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 7667 SV * const sv = kid->op_sv;
5c144d81 7668 U32 was_readonly = SvREADONLY(sv);
8990e307 7669 char *s;
cfff9797
NC		 7670 STRLEN len;
7671 const char *end;
5c144d81
NC		 7672
7673 if (was_readonly) {
7674 if (SvFAKE(sv)) {
7675 sv_force_normal_flags(sv, 0);
7676 assert(!SvREADONLY(sv));
7677 was_readonly = 0;
7678 } else {
7679 SvREADONLY_off(sv);
7680 }
7681 }
7682
cfff9797
NC		 7683 s = SvPVX(sv);
7684 len = SvCUR(sv);
7685 end = s + len;
7686 for (; s < end; s++) {
a0d0e21e
LW		 7687 if (*s == ':' && s[1] == ':') {
7688 *s = '/';
5c6b2528 7689 Move(s+2, s+1, end - s - 1, char);
cfff9797 7690 --end;
a0d0e21e 7691 }
8990e307 7692 }
cfff9797 7693 SvEND_set(sv, end);
396482e1 7694 sv_catpvs(sv, ".pm");
5c144d81 7695 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 7696 }
7697 }
ec4ab249 7698
a72a1c8b
RGS		 7699 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7700 /* handle override, if any */
fafc274c 7701 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 7702 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 7703 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 7704 gv = gvp ? *gvp : NULL;
d6a985f2 7705 }
a72a1c8b 7706 }
ec4ab249 7707
b9f751c0 7708 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 7709 OP * const kid = cUNOPo->op_first;
f11453cb
NC		 7710 OP * newop;
7711
ec4ab249 7712 cUNOPo->op_first = 0;
f11453cb 7713#ifndef PERL_MAD
ec4ab249 7714 op_free(o);
eb8433b7 7715#endif
f11453cb
NC		 7716 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7717 append_elem(OP_LIST, kid,
7718 scalar(newUNOP(OP_RV2CV, 0,
7719 newGVOP(OP_GV, 0,
7720 gv))))));
7721 op_getmad(o,newop,'O');
eb8433b7 7722 return newop;
ec4ab249
GA		 7723 }
7724
021f53de 7725 return scalar(ck_fun(o));
8990e307
LW		 7726}
7727
78f9721b
SM		 7728OP *
7729Perl_ck_return(pTHX_ OP *o)
7730{
97aff369 7731 dVAR;
e91684bf 7732 OP *kid;
7918f24d
NC		 7733
7734 PERL_ARGS_ASSERT_CK_RETURN;
7735
e91684bf 7736 kid = cLISTOPo->op_first->op_sibling;
78f9721b 7737 if (CvLVALUE(PL_compcv)) {
e91684bf 7738 for (; kid; kid = kid->op_sibling)
78f9721b 7739 mod(kid, OP_LEAVESUBLV);
e91684bf
VP		 7740 } else {
7741 for (; kid; kid = kid->op_sibling)
7742 if ((kid->op_type == OP_NULL)
1c8a4223 7743 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
e91684bf 7744 /* This is a do block */
1c8a4223
VP		 7745 OP *op = kUNOP->op_first;
7746 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7747 op = cUNOPx(op)->op_first;
7748 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7749 /* Force the use of the caller's context */
7750 op->op_flags |= OPf_SPECIAL;
7751 }
e91684bf 7752 }
78f9721b 7753 }
e91684bf 7754
78f9721b
SM		 7755 return o;
7756}
7757
79072805 7758OP *
cea2e8a9 7759Perl_ck_select(pTHX_ OP *o)
79072805 7760{
27da23d5 7761 dVAR;
c07a80fd 7762 OP* kid;
7918f24d
NC		 7763
7764 PERL_ARGS_ASSERT_CK_SELECT;
7765
11343788
MB		 7766 if (o->op_flags & OPf_KIDS) {
7767 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 7768 if (kid && kid->op_sibling) {
11343788 7769 o->op_type = OP_SSELECT;
22c35a8c 7770 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 7771 o = ck_fun(o);
7772 return fold_constants(o);
79072805
LW		 7773 }
7774 }
11343788
MB		 7775 o = ck_fun(o);
7776 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 7777 if (kid && kid->op_type == OP_RV2GV)
7778 kid->op_private &= ~HINT_STRICT_REFS;
11343788 7779 return o;
79072805
LW		 7780}
7781
7782OP *
cea2e8a9 7783Perl_ck_shift(pTHX_ OP *o)
79072805 7784{
97aff369 7785 dVAR;
6867be6d 7786 const I32 type = o->op_type;
79072805 7787
7918f24d
NC		 7788 PERL_ARGS_ASSERT_CK_SHIFT;
7789
11343788 7790 if (!(o->op_flags & OPf_KIDS)) {
538f5756
RZ		 7791 OP *argop;
7792
7793 if (!CvUNIQUE(PL_compcv)) {
7794 o->op_flags |= OPf_SPECIAL;
7795 return o;
7796 }
7797
7798 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
eb8433b7 7799#ifdef PERL_MAD
821005df 7800 OP * const oldo = o;
eb8433b7
NC		 7801 o = newUNOP(type, 0, scalar(argop));
7802 op_getmad(oldo,o,'O');
7803 return o;
7804#else
821005df 7805 op_free(o);
6d4ff0d2 7806 return newUNOP(type, 0, scalar(argop));
eb8433b7 7807#endif
79072805 7808 }
11343788 7809 return scalar(modkids(ck_fun(o), type));
79072805
LW		 7810}
7811
7812OP *
cea2e8a9 7813Perl_ck_sort(pTHX_ OP *o)
79072805 7814{
97aff369 7815 dVAR;
8e3f9bdf 7816 OP *firstkid;
bbce6d69 7817
7918f24d
NC		 7818 PERL_ARGS_ASSERT_CK_SORT;
7819
1496a290 7820 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
a4fc7abc 7821 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 7822 if (hinthv) {
a4fc7abc 7823 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 7824 if (svp) {
a4fc7abc 7825 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 7826 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7827 o->op_private |= OPpSORT_QSORT;
7828 if ((sorthints & HINT_SORT_STABLE) != 0)
7829 o->op_private |= OPpSORT_STABLE;
7830 }
7831 }
7832 }
7833
9ea6e965 7834 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 7835 simplify_sort(o);
8e3f9bdf
GS		 7836 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7837 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 7838 OP *k = NULL;
8e3f9bdf 7839 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 7840
463ee0b2 7841 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 7842 linklist(kid);
463ee0b2
LW		 7843 if (kid->op_type == OP_SCOPE) {
7844 k = kid->op_next;
7845 kid->op_next = 0;
79072805 7846 }
463ee0b2 7847 else if (kid->op_type == OP_LEAVE) {
11343788 7848 if (o->op_type == OP_SORT) {
93c66552 7849 op_null(kid); /* wipe out leave */
748a9306 7850 kid->op_next = kid;
463ee0b2 7851
748a9306
LW		 7852 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7853 if (k->op_next == kid)
7854 k->op_next = 0;
71a29c3c
GS		 7855 /* don't descend into loops */
7856 else if (k->op_type == OP_ENTERLOOP
7857 || k->op_type == OP_ENTERITER)
7858 {
7859 k = cLOOPx(k)->op_lastop;
7860 }
748a9306 7861 }
463ee0b2 7862 }
748a9306
LW		 7863 else
7864 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 7865 k = kLISTOP->op_first;
463ee0b2 7866 }
a2efc822 7867 CALL_PEEP(k);
a0d0e21e 7868
8e3f9bdf
GS		 7869 kid = firstkid;
7870 if (o->op_type == OP_SORT) {
7871 /* provide scalar context for comparison function/block */
7872 kid = scalar(kid);
a0d0e21e 7873 kid->op_next = kid;
8e3f9bdf 7874 }
a0d0e21e
LW		 7875 else
7876 kid->op_next = k;
11343788 7877 o->op_flags |= OPf_SPECIAL;
79072805 7878 }
c6e96bcb 7879 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 7880 op_null(firstkid);
8e3f9bdf
GS		 7881
7882 firstkid = firstkid->op_sibling;
79072805 7883 }
bbce6d69 7884
8e3f9bdf
GS		 7885 /* provide list context for arguments */
7886 if (o->op_type == OP_SORT)
7887 list(firstkid);
7888
11343788 7889 return o;
79072805 7890}
bda4119b
GS		 7891
7892STATIC void
cea2e8a9 7893S_simplify_sort(pTHX_ OP *o)
9c007264 7894{
97aff369 7895 dVAR;
9c007264
JH		 7896 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7897 OP *k;
eb209983 7898 int descending;
350de78d 7899 GV *gv;
770526c1 7900 const char *gvname;
7918f24d
NC		 7901
7902 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7903
9c007264
JH		 7904 if (!(o->op_flags & OPf_STACKED))
7905 return;
fafc274c
NC		 7906 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7907 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 7908 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 7909 if (kid->op_type != OP_SCOPE)
7910 return;
7911 kid = kLISTOP->op_last; /* get past scope */
7912 switch(kid->op_type) {
7913 case OP_NCMP:
7914 case OP_I_NCMP:
7915 case OP_SCMP:
7916 break;
7917 default:
7918 return;
7919 }
7920 k = kid; /* remember this node*/
7921 if (kBINOP->op_first->op_type != OP_RV2SV)
7922 return;
7923 kid = kBINOP->op_first; /* get past cmp */
7924 if (kUNOP->op_first->op_type != OP_GV)
7925 return;
7926 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7927 gv = kGVOP_gv;
350de78d 7928 if (GvSTASH(gv) != PL_curstash)
9c007264 7929 return;
770526c1
NC		 7930 gvname = GvNAME(gv);
7931 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 7932 descending = 0;
770526c1 7933 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 7934 descending = 1;
9c007264
JH		 7935 else
7936 return;
eb209983 7937
9c007264
JH		 7938 kid = k; /* back to cmp */
7939 if (kBINOP->op_last->op_type != OP_RV2SV)
7940 return;
7941 kid = kBINOP->op_last; /* down to 2nd arg */
7942 if (kUNOP->op_first->op_type != OP_GV)
7943 return;
7944 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7945 gv = kGVOP_gv;
770526c1
NC		 7946 if (GvSTASH(gv) != PL_curstash)
7947 return;
7948 gvname = GvNAME(gv);
7949 if ( descending
7950 ? !(*gvname == 'a' && gvname[1] == '\0')
7951 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 7952 return;
7953 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 7954 if (descending)
7955 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 7956 if (k->op_type == OP_NCMP)
7957 o->op_private |= OPpSORT_NUMERIC;
7958 if (k->op_type == OP_I_NCMP)
7959 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 7960 kid = cLISTOPo->op_first->op_sibling;
7961 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 7962#ifdef PERL_MAD
7963 op_getmad(kid,o,'S'); /* then delete it */
7964#else
e507f050 7965 op_free(kid); /* then delete it */
eb8433b7 7966#endif
9c007264 7967}
79072805
LW		 7968
7969OP *
cea2e8a9 7970Perl_ck_split(pTHX_ OP *o)
79072805 7971{
27da23d5 7972 dVAR;
79072805 7973 register OP *kid;
aeea060c 7974
7918f24d
NC		 7975 PERL_ARGS_ASSERT_CK_SPLIT;
7976
11343788
MB		 7977 if (o->op_flags & OPf_STACKED)
7978 return no_fh_allowed(o);
79072805 7979
11343788 7980 kid = cLISTOPo->op_first;
8990e307 7981 if (kid->op_type != OP_NULL)
cea2e8a9 7982 Perl_croak(aTHX_ "panic: ck_split");
8990e307 7983 kid = kid->op_sibling;
11343788
MB		 7984 op_free(cLISTOPo->op_first);
7985 cLISTOPo->op_first = kid;
85e6fe83 7986 if (!kid) {
396482e1 7987 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 7988 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 7989 }
79072805 7990
de4bf5b3 7991 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 7992 OP * const sibl = kid->op_sibling;
463ee0b2 7993 kid->op_sibling = 0;
131b3ad0 7994 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 7995 if (cLISTOPo->op_first == cLISTOPo->op_last)
7996 cLISTOPo->op_last = kid;
7997 cLISTOPo->op_first = kid;
79072805
LW		 7998 kid->op_sibling = sibl;
7999 }
8000
8001 kid->op_type = OP_PUSHRE;
22c35a8c 8002 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 8003 scalar(kid);
a2a5de95
NC		 8004 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8005 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8006 "Use of /g modifier is meaningless in split");
f34840d8 8007 }
79072805
LW		 8008
8009 if (!kid->op_sibling)
54b9620d 8010 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 8011
8012 kid = kid->op_sibling;
8013 scalar(kid);
8014
8015 if (!kid->op_sibling)
11343788 8016 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
ce3e5c45 8017 assert(kid->op_sibling);
79072805
LW		 8018
8019 kid = kid->op_sibling;
8020 scalar(kid);
8021
8022 if (kid->op_sibling)
53e06cf0 8023 return too_many_arguments(o,OP_DESC(o));
79072805 8024
11343788 8025 return o;
79072805
LW		 8026}
8027
8028OP *
1c846c1f 8029Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 8030{
551405c4 8031 const OP * const kid = cLISTOPo->op_first->op_sibling;
7918f24d
NC		 8032
8033 PERL_ARGS_ASSERT_CK_JOIN;
8034
041457d9
DM		 8035 if (kid && kid->op_type == OP_MATCH) {
8036 if (ckWARN(WARN_SYNTAX)) {
6867be6d 8037 const REGEXP *re = PM_GETRE(kPMOP);
d2c6dc5e 8038 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
220fc49f 8039 const STRLEN len = re ? RX_PRELEN(re) : 6;
9014280d 8040 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
bcdf7404 8041 "/%.*s/ should probably be written as \"%.*s\"",
d83b45b8 8042 (int)len, pmstr, (int)len, pmstr);
eb6e2d6f
GS		 8043 }
8044 }
8045 return ck_fun(o);
8046}
8047
8048OP *
cea2e8a9 8049Perl_ck_subr(pTHX_ OP *o)
79072805 8050{
97aff369 8051 dVAR;
11343788
MB		 8052 OP *prev = ((cUNOPo->op_first->op_sibling)
8053 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
8054 OP *o2 = prev->op_sibling;
4633a7c4 8055 OP *cvop;
a0751766 8056 const char *proto = NULL;
cbf82dd0 8057 const char *proto_end = NULL;
c445ea15
AL		 8058 CV *cv = NULL;
8059 GV *namegv = NULL;
4633a7c4
LW		 8060 int optional = 0;
8061 I32 arg = 0;
5b794e05 8062 I32 contextclass = 0;
d3fcec1f 8063 const char *e = NULL;
0723351e 8064 bool delete_op = 0;
4633a7c4 8065
7918f24d
NC		 8066 PERL_ARGS_ASSERT_CK_SUBR;
8067
d3011074 8068 o->op_private |= OPpENTERSUB_HASTARG;
11343788 8069 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4 8070 if (cvop->op_type == OP_RV2CV) {
11343788 8071 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 8072 op_null(cvop); /* disable rv2cv */
f7461760
Z		 8073 if (!(o->op_private & OPpENTERSUB_AMPER)) {
8074 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
8075 GV *gv = NULL;
8076 switch (tmpop->op_type) {
8077 case OP_GV: {
8078 gv = cGVOPx_gv(tmpop);
8079 cv = GvCVu(gv);
8080 if (!cv)
8081 tmpop->op_private |= OPpEARLY_CV;
8082 } break;
8083 case OP_CONST: {
8084 SV *sv = cSVOPx_sv(tmpop);
8085 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8086 cv = (CV*)SvRV(sv);
8087 } break;
8088 }
8089 if (cv && SvPOK(cv)) {
8090 STRLEN len;
8091 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8092 proto = SvPV(MUTABLE_SV(cv), len);
8093 proto_end = proto + len;
46fc3d4c 8094 }
4633a7c4
LW		 8095 }
8096 }
f5d5a27c 8097 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 8098 if (o2->op_type == OP_CONST)
8099 o2->op_private &= ~OPpCONST_STRICT;
58a40671 8100 else if (o2->op_type == OP_LIST) {
5f66b61c
AL		 8101 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8102 if (sib && sib->op_type == OP_CONST)
8103 sib->op_private &= ~OPpCONST_STRICT;
58a40671 8104 }
7a52d87a 8105 }
3280af22
NIS		 8106 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8107 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 8108 o->op_private |= OPpENTERSUB_DB;
8109 while (o2 != cvop) {
eb8433b7 8110 OP* o3;
9fc012f4
GG		 8111 if (PL_madskills && o2->op_type == OP_STUB) {
8112 o2 = o2->op_sibling;
8113 continue;
8114 }
eb8433b7
NC		 8115 if (PL_madskills && o2->op_type == OP_NULL)
8116 o3 = ((UNOP*)o2)->op_first;
8117 else
8118 o3 = o2;
4633a7c4 8119 if (proto) {
cbf82dd0 8120 if (proto >= proto_end)
5dc0d613 8121 return too_many_arguments(o, gv_ename(namegv));
cbf82dd0
NC		 8122
8123 switch (*proto) {
4633a7c4
LW		 8124 case ';':
8125 optional = 1;
8126 proto++;
8127 continue;
b13fd70a 8128 case '_':
f00d1d61 8129 /* _ must be at the end */
cb40c25d 8130 if (proto[1] && proto[1] != ';')
f00d1d61 8131 goto oops;
4633a7c4
LW		 8132 case '$':
8133 proto++;
8134 arg++;
11343788 8135 scalar(o2);
4633a7c4
LW		 8136 break;
8137 case '%':
8138 case '@':
11343788 8139 list(o2);
4633a7c4
LW		 8140 arg++;
8141 break;
8142 case '&':
8143 proto++;
8144 arg++;
eb8433b7 8145 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
75fc29ea 8146 bad_type(arg,
666ea192
JH		 8147 arg == 1 ? "block or sub {}" : "sub {}",
8148 gv_ename(namegv), o3);
4633a7c4
LW		 8149 break;
8150 case '*':
2ba6ecf4 8151 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 8152 proto++;
8153 arg++;
eb8433b7 8154 if (o3->op_type == OP_RV2GV)
2ba6ecf4 8155 goto wrapref; /* autoconvert GLOB -> GLOBref */
eb8433b7
NC		 8156 else if (o3->op_type == OP_CONST)
8157 o3->op_private &= ~OPpCONST_STRICT;
8158 else if (o3->op_type == OP_ENTERSUB) {
9675f7ac 8159 /* accidental subroutine, revert to bareword */
eb8433b7 8160 OP *gvop = ((UNOP*)o3)->op_first;
9675f7ac
GS		 8161 if (gvop && gvop->op_type == OP_NULL) {
8162 gvop = ((UNOP*)gvop)->op_first;
8163 if (gvop) {
8164 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8165 ;
8166 if (gvop &&
8167 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8168 (gvop = ((UNOP*)gvop)->op_first) &&
8169 gvop->op_type == OP_GV)
8170 {
551405c4
AL		 8171 GV * const gv = cGVOPx_gv(gvop);
8172 OP * const sibling = o2->op_sibling;
396482e1 8173 SV * const n = newSVpvs("");
eb8433b7 8174#ifdef PERL_MAD
1d866c12 8175 OP * const oldo2 = o2;
eb8433b7 8176#else
9675f7ac 8177 op_free(o2);
eb8433b7 8178#endif
2a797ae2 8179 gv_fullname4(n, gv, "", FALSE);
2692f720 8180 o2 = newSVOP(OP_CONST, 0, n);
eb8433b7 8181 op_getmad(oldo2,o2,'O');
9675f7ac
GS		 8182 prev->op_sibling = o2;
8183 o2->op_sibling = sibling;
8184 }
8185 }
8186 }
8187 }
2ba6ecf4
GS		 8188 scalar(o2);
8189 break;
5b794e05
JH		 8190 case '[': case ']':
8191 goto oops;
8192 break;
4633a7c4
LW		 8193 case '\\':
8194 proto++;
8195 arg++;
5b794e05 8196 again:
4633a7c4 8197 switch (*proto++) {
5b794e05
JH		 8198 case '[':
8199 if (contextclass++ == 0) {
841d93c8 8200 e = strchr(proto, ']');
5b794e05
JH		 8201 if (!e || e == proto)
8202 goto oops;
8203 }
8204 else
8205 goto oops;
8206 goto again;
8207 break;
8208 case ']':
466bafcd 8209 if (contextclass) {
a0751766
NC		 8210 const char *p = proto;
8211 const char *const end = proto;
466bafcd 8212 contextclass = 0;
47127b64 8213 while (*--p != '[') {}
a0751766
NC		 8214 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8215 (int)(end - p), p),
8216 gv_ename(namegv), o3);
466bafcd 8217 } else
5b794e05
JH		 8218 goto oops;
8219 break;
4633a7c4 8220 case '*':
eb8433b7 8221 if (o3->op_type == OP_RV2GV)
5b794e05
JH		 8222 goto wrapref;
8223 if (!contextclass)
eb8433b7 8224 bad_type(arg, "symbol", gv_ename(namegv), o3);
5b794e05 8225 break;
4633a7c4 8226 case '&':
eb8433b7 8227 if (o3->op_type == OP_ENTERSUB)
5b794e05
JH		 8228 goto wrapref;
8229 if (!contextclass)
eb8433b7
NC		 8230 bad_type(arg, "subroutine entry", gv_ename(namegv),
8231 o3);
5b794e05 8232 break;
4633a7c4 8233 case '$':
eb8433b7
NC		 8234 if (o3->op_type == OP_RV2SV ||
8235 o3->op_type == OP_PADSV ||
8236 o3->op_type == OP_HELEM ||
5b9081af 8237 o3->op_type == OP_AELEM)
5b794e05
JH		 8238 goto wrapref;
8239 if (!contextclass)
eb8433b7 8240 bad_type(arg, "scalar", gv_ename(namegv), o3);
5b794e05 8241 break;
4633a7c4 8242 case '@':
eb8433b7
NC		 8243 if (o3->op_type == OP_RV2AV ||
8244 o3->op_type == OP_PADAV)
5b794e05
JH		 8245 goto wrapref;
8246 if (!contextclass)
eb8433b7 8247 bad_type(arg, "array", gv_ename(namegv), o3);
5b794e05 8248 break;
4633a7c4 8249 case '%':
eb8433b7
NC		 8250 if (o3->op_type == OP_RV2HV ||
8251 o3->op_type == OP_PADHV)
5b794e05
JH		 8252 goto wrapref;
8253 if (!contextclass)
eb8433b7 8254 bad_type(arg, "hash", gv_ename(namegv), o3);
5b794e05
JH		 8255 break;
8256 wrapref:
4633a7c4 8257 {
551405c4
AL		 8258 OP* const kid = o2;
8259 OP* const sib = kid->op_sibling;
4633a7c4 8260 kid->op_sibling = 0;
6fa846a0
GS		 8261 o2 = newUNOP(OP_REFGEN, 0, kid);
8262 o2->op_sibling = sib;
e858de61 8263 prev->op_sibling = o2;
4633a7c4 8264 }
841d93c8 8265 if (contextclass && e) {
5b794e05
JH		 8266 proto = e + 1;
8267 contextclass = 0;
8268 }
4633a7c4
LW		 8269 break;
8270 default: goto oops;
8271 }
5b794e05
JH		 8272 if (contextclass)
8273 goto again;
4633a7c4 8274 break;
b1cb66bf 8275 case ' ':
8276 proto++;
8277 continue;
4633a7c4
LW		 8278 default:
8279 oops:
35c1215d 8280 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
be2597df 8281 gv_ename(namegv), SVfARG(cv));
4633a7c4
LW		 8282 }
8283 }
8284 else
11343788
MB		 8285 list(o2);
8286 mod(o2, OP_ENTERSUB);
8287 prev = o2;
8288 o2 = o2->op_sibling;
551405c4 8289 } /* while */
236b555a
RGS		 8290 if (o2 == cvop && proto && *proto == '_') {
8291 /* generate an access to $_ */
8292 o2 = newDEFSVOP();
8293 o2->op_sibling = prev->op_sibling;
8294 prev->op_sibling = o2; /* instead of cvop */
8295 }
cbf82dd0 8296 if (proto && !optional && proto_end > proto &&
236b555a 8297 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
5dc0d613 8298 return too_few_arguments(o, gv_ename(namegv));
0723351e 8299 if(delete_op) {
eb8433b7 8300#ifdef PERL_MAD
1d866c12 8301 OP * const oldo = o;
eb8433b7 8302#else
06492da6 8303 op_free(o);
eb8433b7 8304#endif
06492da6 8305 o=newSVOP(OP_CONST, 0, newSViv(0));
eb8433b7 8306 op_getmad(oldo,o,'O');
06492da6 8307 }
11343788 8308 return o;
79072805
LW		 8309}
8310
8311OP *
cea2e8a9 8312Perl_ck_svconst(pTHX_ OP *o)
8990e307 8313{
7918f24d 8314 PERL_ARGS_ASSERT_CK_SVCONST;
96a5add6 8315 PERL_UNUSED_CONTEXT;
11343788
MB		 8316 SvREADONLY_on(cSVOPo->op_sv);
8317 return o;
8990e307
LW		 8318}
8319
8320OP *
d4ac975e
GA		 8321Perl_ck_chdir(pTHX_ OP *o)
8322{
8323 if (o->op_flags & OPf_KIDS) {
1496a290 8324 SVOP * const kid = (SVOP*)cUNOPo->op_first;
d4ac975e
GA		 8325
8326 if (kid && kid->op_type == OP_CONST &&
8327 (kid->op_private & OPpCONST_BARE))
8328 {
8329 o->op_flags |= OPf_SPECIAL;
8330 kid->op_private &= ~OPpCONST_STRICT;
8331 }
8332 }
8333 return ck_fun(o);
8334}
8335
8336OP *
cea2e8a9 8337Perl_ck_trunc(pTHX_ OP *o)
79072805 8338{
7918f24d
NC		 8339 PERL_ARGS_ASSERT_CK_TRUNC;
8340
11343788
MB		 8341 if (o->op_flags & OPf_KIDS) {
8342 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 8343
a0d0e21e
LW		 8344 if (kid->op_type == OP_NULL)
8345 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 8346 if (kid && kid->op_type == OP_CONST &&
8347 (kid->op_private & OPpCONST_BARE))
8348 {
11343788 8349 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 8350 kid->op_private &= ~OPpCONST_STRICT;
8351 }
79072805 8352 }
11343788 8353 return ck_fun(o);
79072805
LW		 8354}
8355
35fba0d9 8356OP *
bab9c0ac
RGS		 8357Perl_ck_unpack(pTHX_ OP *o)
8358{
8359 OP *kid = cLISTOPo->op_first;
7918f24d
NC		 8360
8361 PERL_ARGS_ASSERT_CK_UNPACK;
8362
bab9c0ac
RGS		 8363 if (kid->op_sibling) {
8364 kid = kid->op_sibling;
8365 if (!kid->op_sibling)
8366 kid->op_sibling = newDEFSVOP();
8367 }
8368 return ck_fun(o);
8369}
8370
8371OP *
35fba0d9
RG		 8372Perl_ck_substr(pTHX_ OP *o)
8373{
7918f24d
NC		 8374 PERL_ARGS_ASSERT_CK_SUBSTR;
8375
35fba0d9 8376 o = ck_fun(o);
1d866c12 8377 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 8378 OP *kid = cLISTOPo->op_first;
8379
8380 if (kid->op_type == OP_NULL)
8381 kid = kid->op_sibling;
8382 if (kid)
8383 kid->op_flags |= OPf_MOD;
8384
8385 }
8386 return o;
8387}
8388
878d132a
NC		 8389OP *
8390Perl_ck_each(pTHX_ OP *o)
8391{
d75c0fe7 8392 dVAR;
a916b302 8393 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
878d132a 8394
7918f24d
NC		 8395 PERL_ARGS_ASSERT_CK_EACH;
8396
a916b302
RGS		 8397 if (kid) {
8398 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8399 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8400 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8401 o->op_type = new_type;
8402 o->op_ppaddr = PL_ppaddr[new_type];
8403 }
8404 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8405 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8406 )) {
8407 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8408 return o;
8409 }
878d132a
NC		 8410 }
8411 return ck_fun(o);
8412}
8413
867fa1e2
YO		 8414/* caller is supposed to assign the return to the
8415 container of the rep_op var */
20381b50 8416STATIC OP *
867fa1e2 8417S_opt_scalarhv(pTHX_ OP *rep_op) {
749123ff 8418 dVAR;
867fa1e2
YO		 8419 UNOP *unop;
8420
8421 PERL_ARGS_ASSERT_OPT_SCALARHV;
8422
8423 NewOp(1101, unop, 1, UNOP);
8424 unop->op_type = (OPCODE)OP_BOOLKEYS;
8425 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8426 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8427 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8428 unop->op_first = rep_op;
8429 unop->op_next = rep_op->op_next;
8430 rep_op->op_next = (OP*)unop;
8431 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8432 unop->op_sibling = rep_op->op_sibling;
8433 rep_op->op_sibling = NULL;
8434 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8435 if (rep_op->op_type == OP_PADHV) {
8436 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8437 rep_op->op_flags |= OPf_WANT_LIST;
8438 }
8439 return (OP*)unop;
8440}
8441
2f9e2db0
VP		 8442/* Checks if o acts as an in-place operator on an array. oright points to the
8443 * beginning of the right-hand side. Returns the left-hand side of the
8444 * assignment if o acts in-place, or NULL otherwise. */
8445
20381b50 8446STATIC OP *
2f9e2db0
VP		 8447S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8448 OP *o2;
8449 OP *oleft = NULL;
8450
8451 PERL_ARGS_ASSERT_IS_INPLACE_AV;
8452
8453 if (!oright ||
8454 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8455 || oright->op_next != o
8456 || (oright->op_private & OPpLVAL_INTRO)
8457 )
8458 return NULL;
8459
8460 /* o2 follows the chain of op_nexts through the LHS of the
8461 * assign (if any) to the aassign op itself */
8462 o2 = o->op_next;
8463 if (!o2 || o2->op_type != OP_NULL)
8464 return NULL;
8465 o2 = o2->op_next;
8466 if (!o2 || o2->op_type != OP_PUSHMARK)
8467 return NULL;
8468 o2 = o2->op_next;
8469 if (o2 && o2->op_type == OP_GV)
8470 o2 = o2->op_next;
8471 if (!o2
8472 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8473 || (o2->op_private & OPpLVAL_INTRO)
8474 )
8475 return NULL;
8476 oleft = o2;
8477 o2 = o2->op_next;
8478 if (!o2 || o2->op_type != OP_NULL)
8479 return NULL;
8480 o2 = o2->op_next;
8481 if (!o2 || o2->op_type != OP_AASSIGN
8482 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8483 return NULL;
8484
8485 /* check that the sort is the first arg on RHS of assign */
8486
8487 o2 = cUNOPx(o2)->op_first;
8488 if (!o2 || o2->op_type != OP_NULL)
8489 return NULL;
8490 o2 = cUNOPx(o2)->op_first;
8491 if (!o2 || o2->op_type != OP_PUSHMARK)
8492 return NULL;
8493 if (o2->op_sibling != o)
8494 return NULL;
8495
8496 /* check the array is the same on both sides */
8497 if (oleft->op_type == OP_RV2AV) {
8498 if (oright->op_type != OP_RV2AV
8499 || !cUNOPx(oright)->op_first
8500 || cUNOPx(oright)->op_first->op_type != OP_GV
8501 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8502 cGVOPx_gv(cUNOPx(oright)->op_first)
8503 )
8504 return NULL;
8505 }
8506 else if (oright->op_type != OP_PADAV
8507 || oright->op_targ != oleft->op_targ
8508 )
8509 return NULL;
8510
8511 return oleft;
8512}
8513
61b743bb
DM		 8514/* A peephole optimizer. We visit the ops in the order they're to execute.
8515 * See the comments at the top of this file for more details about when
8516 * peep() is called */
463ee0b2 8517
79072805 8518void
666e7765 8519Perl_peep(pTHX_ register OP *o)
79072805 8520{
27da23d5 8521 dVAR;
c445ea15 8522 register OP* oldop = NULL;
2d8e6c8d 8523
2814eb74 8524 if (!o || o->op_opt)
79072805 8525 return;
a0d0e21e 8526 ENTER;
462e5cf6 8527 SAVEOP();
7766f137 8528 SAVEVPTR(PL_curcop);
a0d0e21e 8529 for (; o; o = o->op_next) {
2814eb74 8530 if (o->op_opt)
a0d0e21e 8531 break;
6d7dd4a5
NC		 8532 /* By default, this op has now been optimised. A couple of cases below
8533 clear this again. */
8534 o->op_opt = 1;
533c011a 8535 PL_op = o;
a0d0e21e
LW		 8536 switch (o->op_type) {
8537 case OP_NEXTSTATE:
8538 case OP_DBSTATE:
3280af22 8539 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e
LW		 8540 break;
8541
a0d0e21e 8542 case OP_CONST:
7a52d87a
GS		 8543 if (cSVOPo->op_private & OPpCONST_STRICT)
8544 no_bareword_allowed(o);
7766f137 8545#ifdef USE_ITHREADS
996c9baa 8546 case OP_HINTSEVAL:
3848b962 8547 case OP_METHOD_NAMED:
7766f137
GS		 8548 /* Relocate sv to the pad for thread safety.
8549 * Despite being a "constant", the SV is written to,
8550 * for reference counts, sv_upgrade() etc. */
8551 if (cSVOP->op_sv) {
6867be6d 8552 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
996c9baa 8553 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 8554 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 8555 * some pad, so make a copy. */
dd2155a4
DM		 8556 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8557 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 8558 SvREFCNT_dec(cSVOPo->op_sv);
8559 }
996c9baa 8560 else if (o->op_type != OP_METHOD_NAMED
052ca17e
NC		 8561 && cSVOPo->op_sv == &PL_sv_undef) {
8562 /* PL_sv_undef is hack - it's unsafe to store it in the
8563 AV that is the pad, because av_fetch treats values of
8564 PL_sv_undef as a "free" AV entry and will merrily
8565 replace them with a new SV, causing pad_alloc to think
8566 that this pad slot is free. (When, clearly, it is not)
8567 */
8568 SvOK_off(PAD_SVl(ix));
8569 SvPADTMP_on(PAD_SVl(ix));
8570 SvREADONLY_on(PAD_SVl(ix));
8571 }
6a7129a1 8572 else {
dd2155a4 8573 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 8574 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 8575 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 8576 /* XXX I don't know how this isn't readonly already. */
dd2155a4 8577 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 8578 }
a0714e2c 8579 cSVOPo->op_sv = NULL;
7766f137
GS		 8580 o->op_targ = ix;
8581 }
8582#endif
07447971
GS		 8583 break;
8584
df91b2c5
AE		 8585 case OP_CONCAT:
8586 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8587 if (o->op_next->op_private & OPpTARGET_MY) {
8588 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 8589 break; /* ignore_optimization */
df91b2c5
AE		 8590 else {
8591 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8592 o->op_targ = o->op_next->op_targ;
8593 o->op_next->op_targ = 0;
8594 o->op_private |= OPpTARGET_MY;
8595 }
8596 }
8597 op_null(o->op_next);
8598 }
df91b2c5 8599 break;
6d7dd4a5
NC		 8600 case OP_STUB:
8601 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8602 break; /* Scalar stub must produce undef. List stub is noop */
8603 }
8604 goto nothin;
79072805 8605 case OP_NULL:
acb36ea4 8606 if (o->op_targ == OP_NEXTSTATE
5edb5b2a 8607 || o->op_targ == OP_DBSTATE)
acb36ea4 8608 {
3280af22 8609 PL_curcop = ((COP*)o);
acb36ea4 8610 }
dad75012
AMS		 8611 /* XXX: We avoid setting op_seq here to prevent later calls
8612 to peep() from mistakenly concluding that optimisation
8613 has already occurred. This doesn't fix the real problem,
8614 though (See 20010220.007). AMS 20010719 */
2814eb74 8615 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 8616 o->op_opt = 0;
f46f2f82 8617 /* FALL THROUGH */
79072805 8618 case OP_SCALAR:
93a17b20 8619 case OP_LINESEQ:
463ee0b2 8620 case OP_SCOPE:
6d7dd4a5 8621 nothin:
a0d0e21e
LW		 8622 if (oldop && o->op_next) {
8623 oldop->op_next = o->op_next;
6d7dd4a5 8624 o->op_opt = 0;
79072805
LW		 8625 continue;
8626 }
79072805
LW		 8627 break;
8628
6a077020 8629 case OP_PADAV:
79072805 8630 case OP_GV:
6a077020 8631 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 8632 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 8633 o->op_next : o->op_next->op_next;
a0d0e21e 8634 IV i;
f9dc862f 8635 if (pop && pop->op_type == OP_CONST &&
af5acbb4 8636 ((PL_op = pop->op_next)) &&
8990e307 8637 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 8638 !(pop->op_next->op_private &
78f9721b 8639 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
fc15ae8f 8640 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
a0d0e21e 8641 <= 255 &&
8990e307
LW		 8642 i >= 0)
8643 {
350de78d 8644 GV *gv;
af5acbb4
DM		 8645 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8646 no_bareword_allowed(pop);
6a077020
DM		 8647 if (o->op_type == OP_GV)
8648 op_null(o->op_next);
93c66552
DM		 8649 op_null(pop->op_next);
8650 op_null(pop);
a0d0e21e
LW		 8651 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8652 o->op_next = pop->op_next->op_next;
22c35a8c 8653 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 8654 o->op_private = (U8)i;
6a077020
DM		 8655 if (o->op_type == OP_GV) {
8656 gv = cGVOPo_gv;
8657 GvAVn(gv);
8658 }
8659 else
8660 o->op_flags |= OPf_SPECIAL;
8661 o->op_type = OP_AELEMFAST;
8662 }
6a077020
DM		 8663 break;
8664 }
8665
8666 if (o->op_next->op_type == OP_RV2SV) {
8667 if (!(o->op_next->op_private & OPpDEREF)) {
8668 op_null(o->op_next);
8669 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8670 | OPpOUR_INTRO);
8671 o->op_next = o->op_next->op_next;
8672 o->op_type = OP_GVSV;
8673 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 8674 }
79072805 8675 }
e476b1b5 8676 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
551405c4 8677 GV * const gv = cGVOPo_gv;
b15aece3 8678 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 8679 /* XXX could check prototype here instead of just carping */
551405c4 8680 SV * const sv = sv_newmortal();
bd61b366 8681 gv_efullname3(sv, gv, NULL);
9014280d 8682 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d 8683 "%"SVf"() called too early to check prototype",
be2597df 8684 SVfARG(sv));
76cd736e
GS		 8685 }
8686 }
89de2904
AMS		 8687 else if (o->op_next->op_type == OP_READLINE
8688 && o->op_next->op_next->op_type == OP_CONCAT
8689 && (o->op_next->op_next->op_flags & OPf_STACKED))
8690 {
d2c45030
AMS		 8691 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8692 o->op_type = OP_RCATLINE;
8693 o->op_flags |= OPf_STACKED;
8694 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 8695 op_null(o->op_next->op_next);
d2c45030 8696 op_null(o->op_next);
89de2904 8697 }
76cd736e 8698
79072805 8699 break;
867fa1e2
YO		 8700
8701 {
8702 OP *fop;
8703 OP *sop;
8704
8705 case OP_NOT:
8706 fop = cUNOP->op_first;
8707 sop = NULL;
8708 goto stitch_keys;
8709 break;
8710
8711 case OP_AND:
79072805 8712 case OP_OR:
c963b151 8713 case OP_DOR:
867fa1e2
YO		 8714 fop = cLOGOP->op_first;
8715 sop = fop->op_sibling;
8716 while (cLOGOP->op_other->op_type == OP_NULL)
8717 cLOGOP->op_other = cLOGOP->op_other->op_next;
666e7765 8718 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
867fa1e2
YO		 8719
8720 stitch_keys:
8721 o->op_opt = 1;
8722 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8723 || ( sop &&
8724 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8725 )
8726 ){
8727 OP * nop = o;
8728 OP * lop = o;
aaf643ce 8729 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
867fa1e2
YO		 8730 while (nop && nop->op_next) {
8731 switch (nop->op_next->op_type) {
8732 case OP_NOT:
8733 case OP_AND:
8734 case OP_OR:
8735 case OP_DOR:
8736 lop = nop = nop->op_next;
8737 break;
8738 case OP_NULL:
8739 nop = nop->op_next;
8740 break;
8741 default:
8742 nop = NULL;
8743 break;
8744 }
8745 }
8746 }
aaf643ce 8747 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
867fa1e2
YO		 8748 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8749 cLOGOP->op_first = opt_scalarhv(fop);
8750 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8751 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8752 }
8753 }
8754
8755
8756 break;
8757 }
8758
8759 case OP_MAPWHILE:
8760 case OP_GREPWHILE:
2c2d71f5
JH		 8761 case OP_ANDASSIGN:
8762 case OP_ORASSIGN:
c963b151 8763 case OP_DORASSIGN:
1a67a97c
SM		 8764 case OP_COND_EXPR:
8765 case OP_RANGE:
c5917253 8766 case OP_ONCE:
fd4d1407
IZ		 8767 while (cLOGOP->op_other->op_type == OP_NULL)
8768 cLOGOP->op_other = cLOGOP->op_other->op_next;
666e7765 8769 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 8770 break;
8771
79072805 8772 case OP_ENTERLOOP:
9c2ca71a 8773 case OP_ENTERITER:
58cccf98
SM		 8774 while (cLOOP->op_redoop->op_type == OP_NULL)
8775 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
666e7765 8776 peep(cLOOP->op_redoop);
58cccf98
SM		 8777 while (cLOOP->op_nextop->op_type == OP_NULL)
8778 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
666e7765 8779 peep(cLOOP->op_nextop);
58cccf98
SM		 8780 while (cLOOP->op_lastop->op_type == OP_NULL)
8781 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
666e7765 8782 peep(cLOOP->op_lastop);
79072805
LW		 8783 break;
8784
79072805 8785 case OP_SUBST:
29f2e912
NC		 8786 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8787 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8788 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8789 cPMOP->op_pmstashstartu.op_pmreplstart
8790 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
666e7765 8791 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 8792 break;
8793
a0d0e21e 8794 case OP_EXEC:
041457d9
DM		 8795 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8796 && ckWARN(WARN_SYNTAX))
8797 {
1496a290
AL		 8798 if (o->op_next->op_sibling) {
8799 const OPCODE type = o->op_next->op_sibling->op_type;
8800 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8801 const line_t oldline = CopLINE(PL_curcop);
8802 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8803 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8804 "Statement unlikely to be reached");
8805 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8806 "\t(Maybe you meant system() when you said exec()?)\n");
8807 CopLINE_set(PL_curcop, oldline);
8808 }
a0d0e21e
LW		 8809 }
8810 }
8811 break;
b2ffa427 8812
c750a3ec 8813 case OP_HELEM: {
e75d1f10 8814 UNOP *rop;
6d822dc4 8815 SV *lexname;
e75d1f10 8816 GV **fields;
6d822dc4 8817 SV **svp, *sv;
d5263905 8818 const char *key = NULL;
c750a3ec 8819 STRLEN keylen;
b2ffa427 8820
1c846c1f 8821 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 8822 break;
1c846c1f
NIS		 8823
8824 /* Make the CONST have a shared SV */
8825 svp = cSVOPx_svp(((BINOP*)o)->op_last);
38bb37b9 8826 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
d5263905 8827 key = SvPV_const(sv, keylen);
25716404 8828 lexname = newSVpvn_share(key,
bb7a0f54 8829 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
25716404 8830 0);
1c846c1f
NIS		 8831 SvREFCNT_dec(sv);
8832 *svp = lexname;
8833 }
e75d1f10
RD		 8834
8835 if ((o->op_private & (OPpLVAL_INTRO)))
8836 break;
8837
8838 rop = (UNOP*)((BINOP*)o)->op_first;
8839 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8840 break;
8841 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
00b1698f 8842 if (!SvPAD_TYPED(lexname))
e75d1f10 8843 break;
a4fc7abc 8844 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 8845 if (!fields || !GvHV(*fields))
8846 break;
93524f2b 8847 key = SvPV_const(*svp, keylen);
e75d1f10 8848 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 8849 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 8850 {
8851 Perl_croak(aTHX_ "No such class field \"%s\" "
8852 "in variable %s of type %s",
93524f2b 8853 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8854 }
8855
6d822dc4
MS		 8856 break;
8857 }
c750a3ec 8858
e75d1f10
RD		 8859 case OP_HSLICE: {
8860 UNOP *rop;
8861 SV *lexname;
8862 GV **fields;
8863 SV **svp;
93524f2b 8864 const char *key;
e75d1f10
RD		 8865 STRLEN keylen;
8866 SVOP *first_key_op, *key_op;
8867
8868 if ((o->op_private & (OPpLVAL_INTRO))
8869 /* I bet there's always a pushmark... */
8870 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8871 /* hmmm, no optimization if list contains only one key. */
8872 break;
8873 rop = (UNOP*)((LISTOP*)o)->op_last;
8874 if (rop->op_type != OP_RV2HV)
8875 break;
8876 if (rop->op_first->op_type == OP_PADSV)
8877 /* @$hash{qw(keys here)} */
8878 rop = (UNOP*)rop->op_first;
8879 else {
8880 /* @{$hash}{qw(keys here)} */
8881 if (rop->op_first->op_type == OP_SCOPE
8882 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8883 {
8884 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8885 }
8886 else
8887 break;
8888 }
8889
8890 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
00b1698f 8891 if (!SvPAD_TYPED(lexname))
e75d1f10 8892 break;
a4fc7abc 8893 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 8894 if (!fields || !GvHV(*fields))
8895 break;
8896 /* Again guessing that the pushmark can be jumped over.... */
8897 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8898 ->op_first->op_sibling;
8899 for (key_op = first_key_op; key_op;
8900 key_op = (SVOP*)key_op->op_sibling) {
8901 if (key_op->op_type != OP_CONST)
8902 continue;
8903 svp = cSVOPx_svp(key_op);
93524f2b 8904 key = SvPV_const(*svp, keylen);
e75d1f10 8905 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 8906 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 8907 {
8908 Perl_croak(aTHX_ "No such class field \"%s\" "
8909 "in variable %s of type %s",
bfcb3514 8910 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8911 }
8912 }
8913 break;
8914 }
0824d667
DM		 8915 case OP_RV2SV:
8916 case OP_RV2AV:
8917 case OP_RV2HV:
8918 if (oldop
8919 && ( oldop->op_type == OP_AELEM
8920 || oldop->op_type == OP_PADSV
8921 || oldop->op_type == OP_RV2SV
8922 || oldop->op_type == OP_RV2GV
8923 || oldop->op_type == OP_HELEM
8924 )
8925 && (oldop->op_private & OPpDEREF)
8926 ) {
8927 o->op_private |= OPpDEREFed;
8928 }
e75d1f10 8929
fe1bc4cf 8930 case OP_SORT: {
fe1bc4cf 8931 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
551405c4 8932 OP *oleft;
fe1bc4cf
DM		 8933 OP *o2;
8934
fe1bc4cf 8935 /* check that RHS of sort is a single plain array */
551405c4 8936 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 8937 if (!oright || oright->op_type != OP_PUSHMARK)
8938 break;
471178c0
NC		 8939
8940 /* reverse sort ... can be optimised. */
8941 if (!cUNOPo->op_sibling) {
8942 /* Nothing follows us on the list. */
551405c4 8943 OP * const reverse = o->op_next;
471178c0
NC		 8944
8945 if (reverse->op_type == OP_REVERSE &&
8946 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 8947 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 8948 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8949 && (cUNOPx(pushmark)->op_sibling == o)) {
8950 /* reverse -> pushmark -> sort */
8951 o->op_private |= OPpSORT_REVERSE;
8952 op_null(reverse);
8953 pushmark->op_next = oright->op_next;
8954 op_null(oright);
8955 }
8956 }
8957 }
8958
8959 /* make @a = sort @a act in-place */
8960
fe1bc4cf
DM		 8961 oright = cUNOPx(oright)->op_sibling;
8962 if (!oright)
8963 break;
8964 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8965 oright = cUNOPx(oright)->op_sibling;
8966 }
8967
2f9e2db0
VP		 8968 oleft = is_inplace_av(o, oright);
8969 if (!oleft)
fe1bc4cf
DM		 8970 break;
8971
8972 /* transfer MODishness etc from LHS arg to RHS arg */
8973 oright->op_flags = oleft->op_flags;
8974 o->op_private |= OPpSORT_INPLACE;
8975
8976 /* excise push->gv->rv2av->null->aassign */
8977 o2 = o->op_next->op_next;
8978 op_null(o2); /* PUSHMARK */
8979 o2 = o2->op_next;
8980 if (o2->op_type == OP_GV) {
8981 op_null(o2); /* GV */
8982 o2 = o2->op_next;
8983 }
8984 op_null(o2); /* RV2AV or PADAV */
8985 o2 = o2->op_next->op_next;
8986 op_null(o2); /* AASSIGN */
8987
8988 o->op_next = o2->op_next;
8989
8990 break;
8991 }
ef3e5ea9
NC		 8992
8993 case OP_REVERSE: {
e682d7b7 8994 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 8995 OP *gvop = NULL;
484c818f 8996 OP *oleft, *oright;
ef3e5ea9 8997 LISTOP *enter, *exlist;
ef3e5ea9 8998
484c818f
VP		 8999 /* @a = reverse @a */
9000 if ((oright = cLISTOPo->op_first)
9001 && (oright->op_type == OP_PUSHMARK)
9002 && (oright = oright->op_sibling)
9003 && (oleft = is_inplace_av(o, oright))) {
9004 OP *o2;
9005
9006 /* transfer MODishness etc from LHS arg to RHS arg */
9007 oright->op_flags = oleft->op_flags;
9008 o->op_private |= OPpREVERSE_INPLACE;
9009
9010 /* excise push->gv->rv2av->null->aassign */
9011 o2 = o->op_next->op_next;
9012 op_null(o2); /* PUSHMARK */
9013 o2 = o2->op_next;
9014 if (o2->op_type == OP_GV) {
9015 op_null(o2); /* GV */
9016 o2 = o2->op_next;
9017 }
9018 op_null(o2); /* RV2AV or PADAV */
9019 o2 = o2->op_next->op_next;
9020 op_null(o2); /* AASSIGN */
9021
9022 o->op_next = o2->op_next;
9023 break;
9024 }
9025
ef3e5ea9
NC		 9026 enter = (LISTOP *) o->op_next;
9027 if (!enter)
9028 break;
9029 if (enter->op_type == OP_NULL) {
9030 enter = (LISTOP *) enter->op_next;
9031 if (!enter)
9032 break;
9033 }
d46f46af
NC		 9034 /* for $a (...) will have OP_GV then OP_RV2GV here.
9035 for (...) just has an OP_GV. */
ce335f37
NC		 9036 if (enter->op_type == OP_GV) {
9037 gvop = (OP *) enter;
9038 enter = (LISTOP *) enter->op_next;
9039 if (!enter)
9040 break;
d46f46af
NC		 9041 if (enter->op_type == OP_RV2GV) {
9042 enter = (LISTOP *) enter->op_next;
9043 if (!enter)
ce335f37 9044 break;
d46f46af 9045 }
ce335f37
NC		 9046 }
9047
ef3e5ea9
NC		 9048 if (enter->op_type != OP_ENTERITER)
9049 break;
9050
9051 iter = enter->op_next;
9052 if (!iter || iter->op_type != OP_ITER)
9053 break;
9054
ce335f37
NC		 9055 expushmark = enter->op_first;
9056 if (!expushmark || expushmark->op_type != OP_NULL
9057 || expushmark->op_targ != OP_PUSHMARK)
9058 break;
9059
9060 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 9061 if (!exlist || exlist->op_type != OP_NULL
9062 || exlist->op_targ != OP_LIST)
9063 break;
9064
9065 if (exlist->op_last != o) {
9066 /* Mmm. Was expecting to point back to this op. */
9067 break;
9068 }
9069 theirmark = exlist->op_first;
9070 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9071 break;
9072
c491ecac 9073 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 9074 /* There's something between the mark and the reverse, eg
9075 for (1, reverse (...))
9076 so no go. */
9077 break;
9078 }
9079
c491ecac
NC		 9080 ourmark = ((LISTOP *)o)->op_first;
9081 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9082 break;
9083
ef3e5ea9
NC		 9084 ourlast = ((LISTOP *)o)->op_last;
9085 if (!ourlast || ourlast->op_next != o)
9086 break;
9087
e682d7b7
NC		 9088 rv2av = ourmark->op_sibling;
9089 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9090 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9091 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9092 /* We're just reversing a single array. */
9093 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9094 enter->op_flags |= OPf_STACKED;
9095 }
9096
ef3e5ea9
NC		 9097 /* We don't have control over who points to theirmark, so sacrifice
9098 ours. */
9099 theirmark->op_next = ourmark->op_next;
9100 theirmark->op_flags = ourmark->op_flags;
ce335f37 9101 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 9102 op_null(ourmark);
9103 op_null(o);
9104 enter->op_private |= OPpITER_REVERSED;
9105 iter->op_private |= OPpITER_REVERSED;
9106
9107 break;
9108 }
e26df76a
NC		 9109
9110 case OP_SASSIGN: {
9111 OP *rv2gv;
9112 UNOP *refgen, *rv2cv;
9113 LISTOP *exlist;
9114
50baa5ea 9115 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
de3370bc
NC		 9116 break;
9117
e26df76a
NC		 9118 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9119 break;
9120
9121 rv2gv = ((BINOP *)o)->op_last;
9122 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9123 break;
9124
9125 refgen = (UNOP *)((BINOP *)o)->op_first;
9126
9127 if (!refgen || refgen->op_type != OP_REFGEN)
9128 break;
9129
9130 exlist = (LISTOP *)refgen->op_first;
9131 if (!exlist || exlist->op_type != OP_NULL
9132 || exlist->op_targ != OP_LIST)
9133 break;
9134
9135 if (exlist->op_first->op_type != OP_PUSHMARK)
9136 break;
9137
9138 rv2cv = (UNOP*)exlist->op_last;
9139
9140 if (rv2cv->op_type != OP_RV2CV)
9141 break;
9142
9143 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9144 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9145 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9146
9147 o->op_private |= OPpASSIGN_CV_TO_GV;
9148 rv2gv->op_private |= OPpDONT_INIT_GV;
9149 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9150
9151 break;
9152 }
9153
fe1bc4cf 9154
0477511c
NC		 9155 case OP_QR:
9156 case OP_MATCH:
29f2e912
NC		 9157 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9158 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9159 }
79072805
LW		 9160 break;
9161 }
a0d0e21e 9162 oldop = o;
79072805 9163 }
a0d0e21e 9164 LEAVE;
79072805 9165}
beab0874 9166
cef6ea9d 9167const char*
1cb0ed9b 9168Perl_custom_op_name(pTHX_ const OP* o)
53e06cf0 9169{
97aff369 9170 dVAR;
e1ec3a88 9171 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 9172 SV* keysv;
9173 HE* he;
9174
7918f24d
NC		 9175 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9176
53e06cf0 9177 if (!PL_custom_op_names) /* This probably shouldn't happen */
27da23d5 9178 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 9179
9180 keysv = sv_2mortal(newSViv(index));
9181
9182 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9183 if (!he)
27da23d5 9184 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 9185
9186 return SvPV_nolen(HeVAL(he));
9187}
9188
cef6ea9d 9189const char*
1cb0ed9b 9190Perl_custom_op_desc(pTHX_ const OP* o)
53e06cf0 9191{
97aff369 9192 dVAR;
e1ec3a88 9193 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 9194 SV* keysv;
9195 HE* he;
9196
7918f24d
NC		 9197 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9198
53e06cf0 9199 if (!PL_custom_op_descs)
27da23d5 9200 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 9201
9202 keysv = sv_2mortal(newSViv(index));
9203
9204 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9205 if (!he)
27da23d5 9206 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 9207
9208 return SvPV_nolen(HeVAL(he));
9209}
19e8ce8e 9210
beab0874
JT		 9211#include "XSUB.h"
9212
9213/* Efficient sub that returns a constant scalar value. */
9214static void
acfe0abc 9215const_sv_xsub(pTHX_ CV* cv)
beab0874 9216{
97aff369 9217 dVAR;
beab0874 9218 dXSARGS;
99ab892b 9219 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9cbac4c7 9220 if (items != 0) {
6f207bd3 9221 NOOP;
9cbac4c7 9222#if 0
fe13d51d 9223 /* diag_listed_as: SKIPME */
9cbac4c7 9224 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 9225 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 9226#endif
9227 }
99ab892b
NC		 9228 if (!sv) {
9229 XSRETURN(0);
9230 }
9a049f1c 9231 EXTEND(sp, 1);
99ab892b 9232 ST(0) = sv;
beab0874
JT		 9233 XSRETURN(1);
9234}
4946a0fa
NC		 9235
9236/*
9237 * Local variables:
9238 * c-indentation-style: bsd
9239 * c-basic-offset: 4
9240 * indent-tabs-mode: t
9241 * End:
9242 *
37442d52
RGS		 9243 * ex: set ts=8 sts=4 sw=4 noet:
9244 */
Unnamed repository; edit this file 'description' to name the repository.