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