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