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