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