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