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