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