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