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