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
Improve warnings about known issues in (?{...}) blocks in the regex engine
[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 910 case OP_SORT:
a2a5de95 911 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553e7bb0 912 break;
79072805 913 }
11343788 914 return o;
79072805
LW		 915}
916
917OP *
864dbfa3 918Perl_scalarvoid(pTHX_ OP *o)
79072805 919{
27da23d5 920 dVAR;
79072805 921 OP *kid;
c445ea15 922 const char* useless = NULL;
8990e307 923 SV* sv;
2ebea0a1
GS		 924 U8 want;
925
7918f24d
NC		 926 PERL_ARGS_ASSERT_SCALARVOID;
927
eb8433b7
NC		 928 /* trailing mad null ops don't count as "there" for void processing */
929 if (PL_madskills &&
930 o->op_type != OP_NULL &&
931 o->op_sibling &&
932 o->op_sibling->op_type == OP_NULL)
933 {
934 OP *sib;
935 for (sib = o->op_sibling;
936 sib && sib->op_type == OP_NULL;
937 sib = sib->op_sibling) ;
938
939 if (!sib)
940 return o;
941 }
942
acb36ea4 943 if (o->op_type == OP_NEXTSTATE
acb36ea4
GS		 944 || o->op_type == OP_DBSTATE
945 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
acb36ea4 946 || o->op_targ == OP_DBSTATE)))
2ebea0a1 947 PL_curcop = (COP*)o; /* for warning below */
79072805 948
54310121 949 /* assumes no premature commitment */
2ebea0a1 950 want = o->op_flags & OPf_WANT;
13765c85
DM		 951 if ((want && want != OPf_WANT_SCALAR)
952 || (PL_parser && PL_parser->error_count)
5dc0d613 953 || o->op_type == OP_RETURN)
7e363e51 954 {
11343788 955 return o;
7e363e51 956 }
79072805 957
b162f9ea 958 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 959 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
960 {
b162f9ea 961 return scalar(o); /* As if inside SASSIGN */
7e363e51 962 }
1c846c1f 963
5dc0d613 964 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 965
11343788 966 switch (o->op_type) {
79072805 967 default:
22c35a8c 968 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 969 break;
36477c24 970 /* FALL THROUGH */
971 case OP_REPEAT:
11343788 972 if (o->op_flags & OPf_STACKED)
8990e307 973 break;
5d82c453
GA		 974 goto func_ops;
975 case OP_SUBSTR:
976 if (o->op_private == 4)
977 break;
8990e307
LW		 978 /* FALL THROUGH */
979 case OP_GVSV:
980 case OP_WANTARRAY:
981 case OP_GV:
74295f0b 982 case OP_SMARTMATCH:
8990e307
LW		 983 case OP_PADSV:
984 case OP_PADAV:
985 case OP_PADHV:
986 case OP_PADANY:
987 case OP_AV2ARYLEN:
8990e307 988 case OP_REF:
a0d0e21e
LW		 989 case OP_REFGEN:
990 case OP_SREFGEN:
8990e307
LW		 991 case OP_DEFINED:
992 case OP_HEX:
993 case OP_OCT:
994 case OP_LENGTH:
8990e307
LW		 995 case OP_VEC:
996 case OP_INDEX:
997 case OP_RINDEX:
998 case OP_SPRINTF:
999 case OP_AELEM:
1000 case OP_AELEMFAST:
1001 case OP_ASLICE:
8990e307
LW		 1002 case OP_HELEM:
1003 case OP_HSLICE:
1004 case OP_UNPACK:
1005 case OP_PACK:
8990e307
LW		 1006 case OP_JOIN:
1007 case OP_LSLICE:
1008 case OP_ANONLIST:
1009 case OP_ANONHASH:
1010 case OP_SORT:
1011 case OP_REVERSE:
1012 case OP_RANGE:
1013 case OP_FLIP:
1014 case OP_FLOP:
1015 case OP_CALLER:
1016 case OP_FILENO:
1017 case OP_EOF:
1018 case OP_TELL:
1019 case OP_GETSOCKNAME:
1020 case OP_GETPEERNAME:
1021 case OP_READLINK:
1022 case OP_TELLDIR:
1023 case OP_GETPPID:
1024 case OP_GETPGRP:
1025 case OP_GETPRIORITY:
1026 case OP_TIME:
1027 case OP_TMS:
1028 case OP_LOCALTIME:
1029 case OP_GMTIME:
1030 case OP_GHBYNAME:
1031 case OP_GHBYADDR:
1032 case OP_GHOSTENT:
1033 case OP_GNBYNAME:
1034 case OP_GNBYADDR:
1035 case OP_GNETENT:
1036 case OP_GPBYNAME:
1037 case OP_GPBYNUMBER:
1038 case OP_GPROTOENT:
1039 case OP_GSBYNAME:
1040 case OP_GSBYPORT:
1041 case OP_GSERVENT:
1042 case OP_GPWNAM:
1043 case OP_GPWUID:
1044 case OP_GGRNAM:
1045 case OP_GGRGID:
1046 case OP_GETLOGIN:
78e1b766 1047 case OP_PROTOTYPE:
5d82c453 1048 func_ops:
64aac5a9 1049 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
74295f0b 1050 /* Otherwise it's "Useless use of grep iterator" */
f5df4782 1051 useless = OP_DESC(o);
8990e307
LW		 1052 break;
1053
9f82cd5f
YST		 1054 case OP_NOT:
1055 kid = cUNOPo->op_first;
1056 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1057 kid->op_type != OP_TRANS) {
1058 goto func_ops;
1059 }
1060 useless = "negative pattern binding (!~)";
1061 break;
1062
8990e307
LW		 1063 case OP_RV2GV:
1064 case OP_RV2SV:
1065 case OP_RV2AV:
1066 case OP_RV2HV:
192587c2 1067 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1068 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1069 useless = "a variable";
1070 break;
79072805
LW		 1071
1072 case OP_CONST:
7766f137 1073 sv = cSVOPo_sv;
7a52d87a
GS		 1074 if (cSVOPo->op_private & OPpCONST_STRICT)
1075 no_bareword_allowed(o);
1076 else {
d008e5eb 1077 if (ckWARN(WARN_VOID)) {
fa01e093
RGS		 1078 if (SvOK(sv)) {
1079 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1080 "a constant (%"SVf")", sv));
1081 useless = SvPV_nolen(msv);
1082 }
1083 else
1084 useless = "a constant (undef)";
2e0ae2d3 1085 if (o->op_private & OPpCONST_ARYBASE)
d4c19fe8 1086 useless = NULL;
e7fec78e 1087 /* don't warn on optimised away booleans, eg
b5a930ec 1088 * use constant Foo, 5; Foo || print; */
e7fec78e 1089 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1090 useless = NULL;
960b4253
MG		 1091 /* the constants 0 and 1 are permitted as they are
1092 conventionally used as dummies in constructs like
1093 1 while some_condition_with_side_effects; */
e7fec78e 1094 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 1095 useless = NULL;
d008e5eb 1096 else if (SvPOK(sv)) {
a52fe3ac
A		 1097 /* perl4's way of mixing documentation and code
1098 (before the invention of POD) was based on a
1099 trick to mix nroff and perl code. The trick was
1100 built upon these three nroff macros being used in
1101 void context. The pink camel has the details in
1102 the script wrapman near page 319. */
6136c704
AL		 1103 const char * const maybe_macro = SvPVX_const(sv);
1104 if (strnEQ(maybe_macro, "di", 2) ||
1105 strnEQ(maybe_macro, "ds", 2) ||
1106 strnEQ(maybe_macro, "ig", 2))
d4c19fe8 1107 useless = NULL;
d008e5eb 1108 }
8990e307
LW		 1109 }
1110 }
93c66552 1111 op_null(o); /* don't execute or even remember it */
79072805
LW		 1112 break;
1113
1114 case OP_POSTINC:
11343788 1115 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1116 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 1117 break;
1118
1119 case OP_POSTDEC:
11343788 1120 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1121 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 1122 break;
1123
679d6c4e
HS		 1124 case OP_I_POSTINC:
1125 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1126 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1127 break;
1128
1129 case OP_I_POSTDEC:
1130 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1131 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1132 break;
1133
79072805
LW		 1134 case OP_OR:
1135 case OP_AND:
edbe35ea
VP		 1136 kid = cLOGOPo->op_first;
1137 if (kid->op_type == OP_NOT
1138 && (kid->op_flags & OPf_KIDS)
1139 && !PL_madskills) {
1140 if (o->op_type == OP_AND) {
1141 o->op_type = OP_OR;
1142 o->op_ppaddr = PL_ppaddr[OP_OR];
1143 } else {
1144 o->op_type = OP_AND;
1145 o->op_ppaddr = PL_ppaddr[OP_AND];
1146 }
1147 op_null(kid);
1148 }
1149
c963b151 1150 case OP_DOR:
79072805 1151 case OP_COND_EXPR:
0d863452
RH		 1152 case OP_ENTERGIVEN:
1153 case OP_ENTERWHEN:
11343788 1154 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1155 scalarvoid(kid);
1156 break;
5aabfad6 1157
a0d0e21e 1158 case OP_NULL:
11343788 1159 if (o->op_flags & OPf_STACKED)
a0d0e21e 1160 break;
5aabfad6 1161 /* FALL THROUGH */
2ebea0a1
GS		 1162 case OP_NEXTSTATE:
1163 case OP_DBSTATE:
79072805
LW		 1164 case OP_ENTERTRY:
1165 case OP_ENTER:
11343788 1166 if (!(o->op_flags & OPf_KIDS))
79072805 1167 break;
54310121 1168 /* FALL THROUGH */
463ee0b2 1169 case OP_SCOPE:
79072805
LW		 1170 case OP_LEAVE:
1171 case OP_LEAVETRY:
a0d0e21e 1172 case OP_LEAVELOOP:
79072805 1173 case OP_LINESEQ:
79072805 1174 case OP_LIST:
0d863452
RH		 1175 case OP_LEAVEGIVEN:
1176 case OP_LEAVEWHEN:
11343788 1177 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1178 scalarvoid(kid);
1179 break;
c90c0ff4 1180 case OP_ENTEREVAL:
5196be3e 1181 scalarkids(o);
c90c0ff4 1182 break;
5aabfad6 1183 case OP_REQUIRE:
c90c0ff4 1184 /* all requires must return a boolean value */
5196be3e 1185 o->op_flags &= ~OPf_WANT;
d6483035
GS		 1186 /* FALL THROUGH */
1187 case OP_SCALAR:
5196be3e 1188 return scalar(o);
79072805 1189 }
a2a5de95
NC		 1190 if (useless)
1191 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 1192 return o;
79072805
LW		 1193}
1194
1f676739 1195static OP *
412da003 1196S_listkids(pTHX_ OP *o)
79072805 1197{
11343788 1198 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1199 OP *kid;
11343788 1200 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1201 list(kid);
1202 }
11343788 1203 return o;
79072805
LW		 1204}
1205
1206OP *
864dbfa3 1207Perl_list(pTHX_ OP *o)
79072805 1208{
27da23d5 1209 dVAR;
79072805
LW		 1210 OP *kid;
1211
a0d0e21e 1212 /* assumes no premature commitment */
13765c85
DM		 1213 if (!o || (o->op_flags & OPf_WANT)
1214 || (PL_parser && PL_parser->error_count)
5dc0d613 1215 || o->op_type == OP_RETURN)
7e363e51 1216 {
11343788 1217 return o;
7e363e51 1218 }
79072805 1219
b162f9ea 1220 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1221 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1222 {
b162f9ea 1223 return o; /* As if inside SASSIGN */
7e363e51 1224 }
1c846c1f 1225
5dc0d613 1226 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1227
11343788 1228 switch (o->op_type) {
79072805
LW		 1229 case OP_FLOP:
1230 case OP_REPEAT:
11343788 1231 list(cBINOPo->op_first);
79072805
LW		 1232 break;
1233 case OP_OR:
1234 case OP_AND:
1235 case OP_COND_EXPR:
11343788 1236 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1237 list(kid);
1238 break;
1239 default:
1240 case OP_MATCH:
8782bef2 1241 case OP_QR:
79072805
LW		 1242 case OP_SUBST:
1243 case OP_NULL:
11343788 1244 if (!(o->op_flags & OPf_KIDS))
79072805 1245 break;
11343788
MB		 1246 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1247 list(cBINOPo->op_first);
1248 return gen_constant_list(o);
79072805
LW		 1249 }
1250 case OP_LIST:
11343788 1251 listkids(o);
79072805
LW		 1252 break;
1253 case OP_LEAVE:
1254 case OP_LEAVETRY:
5dc0d613 1255 kid = cLISTOPo->op_first;
54310121 1256 list(kid);
155aba94 1257 while ((kid = kid->op_sibling)) {
54310121 1258 if (kid->op_sibling)
1259 scalarvoid(kid);
1260 else
1261 list(kid);
1262 }
11206fdd 1263 PL_curcop = &PL_compiling;
54310121 1264 break;
748a9306 1265 case OP_SCOPE:
79072805 1266 case OP_LINESEQ:
11343788 1267 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 1268 if (kid->op_sibling)
1269 scalarvoid(kid);
1270 else
1271 list(kid);
1272 }
11206fdd 1273 PL_curcop = &PL_compiling;
79072805 1274 break;
c90c0ff4 1275 case OP_REQUIRE:
1276 /* all requires must return a boolean value */
5196be3e
MB		 1277 o->op_flags &= ~OPf_WANT;
1278 return scalar(o);
79072805 1279 }
11343788 1280 return o;
79072805
LW		 1281}
1282
1f676739 1283static OP *
2dd5337b 1284S_scalarseq(pTHX_ OP *o)
79072805 1285{
97aff369 1286 dVAR;
11343788 1287 if (o) {
1496a290
AL		 1288 const OPCODE type = o->op_type;
1289
1290 if (type == OP_LINESEQ || type == OP_SCOPE ||
1291 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1292 {
6867be6d 1293 OP *kid;
11343788 1294 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1295 if (kid->op_sibling) {
463ee0b2 1296 scalarvoid(kid);
ed6116ce 1297 }
463ee0b2 1298 }
3280af22 1299 PL_curcop = &PL_compiling;
79072805 1300 }
11343788 1301 o->op_flags &= ~OPf_PARENS;
3280af22 1302 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1303 o->op_flags |= OPf_PARENS;
79072805 1304 }
8990e307 1305 else
11343788
MB		 1306 o = newOP(OP_STUB, 0);
1307 return o;
79072805
LW		 1308}
1309
76e3520e 1310STATIC OP *
cea2e8a9 1311S_modkids(pTHX_ OP *o, I32 type)
79072805 1312{
11343788 1313 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1314 OP *kid;
11343788 1315 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1316 mod(kid, type);
79072805 1317 }
11343788 1318 return o;
79072805
LW		 1319}
1320
ff7298cb 1321/* Propagate lvalue ("modifiable") context to an op and its children.
ddeae0f1
DM		 1322 * 'type' represents the context type, roughly based on the type of op that
1323 * would do the modifying, although local() is represented by OP_NULL.
1324 * It's responsible for detecting things that can't be modified, flag
1325 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1326 * might have to vivify a reference in $x), and so on.
1327 *
1328 * For example, "$a+1 = 2" would cause mod() to be called with o being
1329 * OP_ADD and type being OP_SASSIGN, and would output an error.
1330 */
1331
79072805 1332OP *
864dbfa3 1333Perl_mod(pTHX_ OP *o, I32 type)
79072805 1334{
27da23d5 1335 dVAR;
79072805 1336 OP *kid;
ddeae0f1
DM		 1337 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1338 int localize = -1;
79072805 1339
13765c85 1340 if (!o || (PL_parser && PL_parser->error_count))
11343788 1341 return o;
79072805 1342
b162f9ea 1343 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1344 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1345 {
b162f9ea 1346 return o;
7e363e51 1347 }
1c846c1f 1348
11343788 1349 switch (o->op_type) {
68dc0745 1350 case OP_UNDEF:
ddeae0f1 1351 localize = 0;
3280af22 1352 PL_modcount++;
5dc0d613 1353 return o;
a0d0e21e 1354 case OP_CONST:
2e0ae2d3 1355 if (!(o->op_private & OPpCONST_ARYBASE))
a0d0e21e 1356 goto nomod;
54dc0f91 1357 localize = 0;
3280af22 1358 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
fc15ae8f
NC		 1359 CopARYBASE_set(&PL_compiling,
1360 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
3280af22 1361 PL_eval_start = 0;
a0d0e21e
LW		 1362 }
1363 else if (!type) {
fc15ae8f
NC		 1364 SAVECOPARYBASE(&PL_compiling);
1365 CopARYBASE_set(&PL_compiling, 0);
a0d0e21e
LW		 1366 }
1367 else if (type == OP_REFGEN)
1368 goto nomod;
1369 else
cea2e8a9 1370 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1371 break;
5f05dabc 1372 case OP_STUB:
58bde88d 1373 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc 1374 break;
1375 goto nomod;
a0d0e21e
LW		 1376 case OP_ENTERSUB:
1377 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1378 !(o->op_flags & OPf_STACKED)) {
1379 o->op_type = OP_RV2CV; /* entersub => rv2cv */
e26df76a
NC		 1380 /* The default is to set op_private to the number of children,
1381 which for a UNOP such as RV2CV is always 1. And w're using
1382 the bit for a flag in RV2CV, so we need it clear. */
1383 o->op_private &= ~1;
22c35a8c 1384 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1385 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1386 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1387 break;
1388 }
95f0a2f1
SB		 1389 else if (o->op_private & OPpENTERSUB_NOMOD)
1390 return o;
cd06dffe
GS		 1391 else { /* lvalue subroutine call */
1392 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1393 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1394 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1395 /* Backward compatibility mode: */
1396 o->op_private |= OPpENTERSUB_INARGS;
1397 break;
1398 }
1399 else { /* Compile-time error message: */
1400 OP *kid = cUNOPo->op_first;
1401 CV *cv;
1402 OP *okid;
1403
3ea285d1
AL		 1404 if (kid->op_type != OP_PUSHMARK) {
1405 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1406 Perl_croak(aTHX_
1407 "panic: unexpected lvalue entersub "
1408 "args: type/targ %ld:%"UVuf,
1409 (long)kid->op_type, (UV)kid->op_targ);
1410 kid = kLISTOP->op_first;
1411 }
cd06dffe
GS		 1412 while (kid->op_sibling)
1413 kid = kid->op_sibling;
1414 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1415 /* Indirect call */
1416 if (kid->op_type == OP_METHOD_NAMED
1417 || kid->op_type == OP_METHOD)
1418 {
87d7fd28 1419 UNOP *newop;
b2ffa427 1420
87d7fd28 1421 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1422 newop->op_type = OP_RV2CV;
1423 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
5f66b61c 1424 newop->op_first = NULL;
87d7fd28
GS		 1425 newop->op_next = (OP*)newop;
1426 kid->op_sibling = (OP*)newop;
349fd7b7 1427 newop->op_private |= OPpLVAL_INTRO;
e26df76a 1428 newop->op_private &= ~1;
cd06dffe
GS		 1429 break;
1430 }
b2ffa427 1431
cd06dffe
GS		 1432 if (kid->op_type != OP_RV2CV)
1433 Perl_croak(aTHX_
1434 "panic: unexpected lvalue entersub "
55140b79 1435 "entry via type/targ %ld:%"UVuf,
3d811634 1436 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1437 kid->op_private |= OPpLVAL_INTRO;
1438 break; /* Postpone until runtime */
1439 }
b2ffa427
NIS		 1440
1441 okid = kid;
cd06dffe
GS		 1442 kid = kUNOP->op_first;
1443 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1444 kid = kUNOP->op_first;
b2ffa427 1445 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1446 Perl_croak(aTHX_
1447 "Unexpected constant lvalue entersub "
55140b79 1448 "entry via type/targ %ld:%"UVuf,
3d811634 1449 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1450 if (kid->op_type != OP_GV) {
1451 /* Restore RV2CV to check lvalueness */
1452 restore_2cv:
1453 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1454 okid->op_next = kid->op_next;
1455 kid->op_next = okid;
1456 }
1457 else
5f66b61c 1458 okid->op_next = NULL;
cd06dffe
GS		 1459 okid->op_type = OP_RV2CV;
1460 okid->op_targ = 0;
1461 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1462 okid->op_private |= OPpLVAL_INTRO;
e26df76a 1463 okid->op_private &= ~1;
cd06dffe
GS		 1464 break;
1465 }
b2ffa427 1466
638eceb6 1467 cv = GvCV(kGVOP_gv);
1c846c1f 1468 if (!cv)
cd06dffe
GS		 1469 goto restore_2cv;
1470 if (CvLVALUE(cv))
1471 break;
1472 }
1473 }
79072805
LW		 1474 /* FALL THROUGH */
1475 default:
a0d0e21e 1476 nomod:
6fbb66d6
NC		 1477 /* grep, foreach, subcalls, refgen */
1478 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
a0d0e21e 1479 break;
cea2e8a9 1480 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1481 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1482 ? "do block"
1483 : (o->op_type == OP_ENTERSUB
1484 ? "non-lvalue subroutine call"
53e06cf0 1485 : OP_DESC(o))),
22c35a8c 1486 type ? PL_op_desc[type] : "local"));
11343788 1487 return o;
79072805 1488
a0d0e21e
LW		 1489 case OP_PREINC:
1490 case OP_PREDEC:
1491 case OP_POW:
1492 case OP_MULTIPLY:
1493 case OP_DIVIDE:
1494 case OP_MODULO:
1495 case OP_REPEAT:
1496 case OP_ADD:
1497 case OP_SUBTRACT:
1498 case OP_CONCAT:
1499 case OP_LEFT_SHIFT:
1500 case OP_RIGHT_SHIFT:
1501 case OP_BIT_AND:
1502 case OP_BIT_XOR:
1503 case OP_BIT_OR:
1504 case OP_I_MULTIPLY:
1505 case OP_I_DIVIDE:
1506 case OP_I_MODULO:
1507 case OP_I_ADD:
1508 case OP_I_SUBTRACT:
11343788 1509 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1510 goto nomod;
3280af22 1511 PL_modcount++;
a0d0e21e 1512 break;
b2ffa427 1513
79072805 1514 case OP_COND_EXPR:
ddeae0f1 1515 localize = 1;
11343788 1516 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1517 mod(kid, type);
79072805
LW		 1518 break;
1519
1520 case OP_RV2AV:
1521 case OP_RV2HV:
11343788 1522 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1523 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1524 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1525 }
1526 /* FALL THROUGH */
79072805 1527 case OP_RV2GV:
5dc0d613 1528 if (scalar_mod_type(o, type))
3fe9a6f1 1529 goto nomod;
11343788 1530 ref(cUNOPo->op_first, o->op_type);
79072805 1531 /* FALL THROUGH */
79072805
LW		 1532 case OP_ASLICE:
1533 case OP_HSLICE:
78f9721b
SM		 1534 if (type == OP_LEAVESUBLV)
1535 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1536 localize = 1;
78f9721b
SM		 1537 /* FALL THROUGH */
1538 case OP_AASSIGN:
93a17b20
LW		 1539 case OP_NEXTSTATE:
1540 case OP_DBSTATE:
e6438c1a 1541 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1542 break;
28c5b5bc
RGS		 1543 case OP_AV2ARYLEN:
1544 PL_hints |= HINT_BLOCK_SCOPE;
1545 if (type == OP_LEAVESUBLV)
1546 o->op_private |= OPpMAYBE_LVSUB;
1547 PL_modcount++;
1548 break;
463ee0b2 1549 case OP_RV2SV:
aeea060c 1550 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1551 localize = 1;
463ee0b2 1552 /* FALL THROUGH */
79072805 1553 case OP_GV:
3280af22 1554 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1555 case OP_SASSIGN:
bf4b1e52
GS		 1556 case OP_ANDASSIGN:
1557 case OP_ORASSIGN:
c963b151 1558 case OP_DORASSIGN:
ddeae0f1
DM		 1559 PL_modcount++;
1560 break;
1561
8990e307 1562 case OP_AELEMFAST:
6a077020 1563 localize = -1;
3280af22 1564 PL_modcount++;
8990e307
LW		 1565 break;
1566
748a9306
LW		 1567 case OP_PADAV:
1568 case OP_PADHV:
e6438c1a 1569 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1570 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1571 return o; /* Treat \(@foo) like ordinary list. */
1572 if (scalar_mod_type(o, type))
3fe9a6f1 1573 goto nomod;
78f9721b
SM		 1574 if (type == OP_LEAVESUBLV)
1575 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1576 /* FALL THROUGH */
1577 case OP_PADSV:
3280af22 1578 PL_modcount++;
ddeae0f1 1579 if (!type) /* local() */
cea2e8a9 1580 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1581 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW		 1582 break;
1583
748a9306 1584 case OP_PUSHMARK:
ddeae0f1 1585 localize = 0;
748a9306 1586 break;
b2ffa427 1587
69969c6f
SB		 1588 case OP_KEYS:
1589 if (type != OP_SASSIGN)
1590 goto nomod;
5d82c453
GA		 1591 goto lvalue_func;
1592 case OP_SUBSTR:
1593 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1594 goto nomod;
5f05dabc 1595 /* FALL THROUGH */
a0d0e21e 1596 case OP_POS:
463ee0b2 1597 case OP_VEC:
78f9721b
SM		 1598 if (type == OP_LEAVESUBLV)
1599 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1600 lvalue_func:
11343788
MB		 1601 pad_free(o->op_targ);
1602 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1603 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1604 if (o->op_flags & OPf_KIDS)
1605 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1606 break;
a0d0e21e 1607
463ee0b2
LW		 1608 case OP_AELEM:
1609 case OP_HELEM:
11343788 1610 ref(cBINOPo->op_first, o->op_type);
68dc0745 1611 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1612 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1613 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1614 if (type == OP_LEAVESUBLV)
1615 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1616 localize = 1;
3280af22 1617 PL_modcount++;
463ee0b2
LW		 1618 break;
1619
1620 case OP_SCOPE:
1621 case OP_LEAVE:
1622 case OP_ENTER:
78f9721b 1623 case OP_LINESEQ:
ddeae0f1 1624 localize = 0;
11343788
MB		 1625 if (o->op_flags & OPf_KIDS)
1626 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1627 break;
1628
1629 case OP_NULL:
ddeae0f1 1630 localize = 0;
638bc118
GS		 1631 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1632 goto nomod;
1633 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1634 break;
11343788
MB		 1635 if (o->op_targ != OP_LIST) {
1636 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1637 break;
1638 }
1639 /* FALL THROUGH */
463ee0b2 1640 case OP_LIST:
ddeae0f1 1641 localize = 0;
11343788 1642 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1643 mod(kid, type);
1644 break;
78f9721b
SM		 1645
1646 case OP_RETURN:
1647 if (type != OP_LEAVESUBLV)
1648 goto nomod;
1649 break; /* mod()ing was handled by ck_return() */
463ee0b2 1650 }
58d95175 1651
8be1be90
AMS		 1652 /* [20011101.069] File test operators interpret OPf_REF to mean that
1653 their argument is a filehandle; thus \stat(".") should not set
1654 it. AMS 20011102 */
1655 if (type == OP_REFGEN &&
1656 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1657 return o;
1658
1659 if (type != OP_LEAVESUBLV)
1660 o->op_flags |= OPf_MOD;
1661
1662 if (type == OP_AASSIGN || type == OP_SASSIGN)
1663 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 1664 else if (!type) { /* local() */
1665 switch (localize) {
1666 case 1:
1667 o->op_private |= OPpLVAL_INTRO;
1668 o->op_flags &= ~OPf_SPECIAL;
1669 PL_hints |= HINT_BLOCK_SCOPE;
1670 break;
1671 case 0:
1672 break;
1673 case -1:
a2a5de95
NC		 1674 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1675 "Useless localization of %s", OP_DESC(o));
ddeae0f1 1676 }
463ee0b2 1677 }
8be1be90
AMS		 1678 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1679 && type != OP_LEAVESUBLV)
1680 o->op_flags |= OPf_REF;
11343788 1681 return o;
463ee0b2
LW		 1682}
1683
864dbfa3 1684STATIC bool
5f66b61c 1685S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 1686{
7918f24d
NC		 1687 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1688
3fe9a6f1 1689 switch (type) {
1690 case OP_SASSIGN:
5196be3e 1691 if (o->op_type == OP_RV2GV)
3fe9a6f1 1692 return FALSE;
1693 /* FALL THROUGH */
1694 case OP_PREINC:
1695 case OP_PREDEC:
1696 case OP_POSTINC:
1697 case OP_POSTDEC:
1698 case OP_I_PREINC:
1699 case OP_I_PREDEC:
1700 case OP_I_POSTINC:
1701 case OP_I_POSTDEC:
1702 case OP_POW:
1703 case OP_MULTIPLY:
1704 case OP_DIVIDE:
1705 case OP_MODULO:
1706 case OP_REPEAT:
1707 case OP_ADD:
1708 case OP_SUBTRACT:
1709 case OP_I_MULTIPLY:
1710 case OP_I_DIVIDE:
1711 case OP_I_MODULO:
1712 case OP_I_ADD:
1713 case OP_I_SUBTRACT:
1714 case OP_LEFT_SHIFT:
1715 case OP_RIGHT_SHIFT:
1716 case OP_BIT_AND:
1717 case OP_BIT_XOR:
1718 case OP_BIT_OR:
1719 case OP_CONCAT:
1720 case OP_SUBST:
1721 case OP_TRANS:
49e9fbe6
GS		 1722 case OP_READ:
1723 case OP_SYSREAD:
1724 case OP_RECV:
bf4b1e52
GS		 1725 case OP_ANDASSIGN:
1726 case OP_ORASSIGN:
410d09fe 1727 case OP_DORASSIGN:
3fe9a6f1 1728 return TRUE;
1729 default:
1730 return FALSE;
1731 }
1732}
1733
35cd451c 1734STATIC bool
5f66b61c 1735S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 1736{
7918f24d
NC		 1737 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1738
35cd451c
GS		 1739 switch (o->op_type) {
1740 case OP_PIPE_OP:
1741 case OP_SOCKPAIR:
504618e9 1742 if (numargs == 2)
35cd451c
GS		 1743 return TRUE;
1744 /* FALL THROUGH */
1745 case OP_SYSOPEN:
1746 case OP_OPEN:
ded8aa31 1747 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1748 case OP_SOCKET:
1749 case OP_OPEN_DIR:
1750 case OP_ACCEPT:
504618e9 1751 if (numargs == 1)
35cd451c 1752 return TRUE;
5f66b61c 1753 /* FALLTHROUGH */
35cd451c
GS		 1754 default:
1755 return FALSE;
1756 }
1757}
1758
0d86688d
NC		 1759static OP *
1760S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 1761{
11343788 1762 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1763 OP *kid;
11343788 1764 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1765 ref(kid, type);
1766 }
11343788 1767 return o;
463ee0b2
LW		 1768}
1769
1770OP *
e4c5ccf3 1771Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 1772{
27da23d5 1773 dVAR;
463ee0b2 1774 OP *kid;
463ee0b2 1775
7918f24d
NC		 1776 PERL_ARGS_ASSERT_DOREF;
1777
13765c85 1778 if (!o || (PL_parser && PL_parser->error_count))
11343788 1779 return o;
463ee0b2 1780
11343788 1781 switch (o->op_type) {
a0d0e21e 1782 case OP_ENTERSUB:
afebc493 1783 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1784 !(o->op_flags & OPf_STACKED)) {
1785 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1786 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1787 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1788 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1789 o->op_flags |= OPf_SPECIAL;
e26df76a 1790 o->op_private &= ~1;
8990e307
LW		 1791 }
1792 break;
aeea060c 1793
463ee0b2 1794 case OP_COND_EXPR:
11343788 1795 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 1796 doref(kid, type, set_op_ref);
463ee0b2 1797 break;
8990e307 1798 case OP_RV2SV:
35cd451c
GS		 1799 if (type == OP_DEFINED)
1800 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1801 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 1802 /* FALL THROUGH */
1803 case OP_PADSV:
5f05dabc 1804 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1805 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1806 : type == OP_RV2HV ? OPpDEREF_HV
1807 : OPpDEREF_SV);
11343788 1808 o->op_flags |= OPf_MOD;
a0d0e21e 1809 }
8990e307 1810 break;
1c846c1f 1811
463ee0b2
LW		 1812 case OP_RV2AV:
1813 case OP_RV2HV:
e4c5ccf3
RH		 1814 if (set_op_ref)
1815 o->op_flags |= OPf_REF;
8990e307 1816 /* FALL THROUGH */
463ee0b2 1817 case OP_RV2GV:
35cd451c
GS		 1818 if (type == OP_DEFINED)
1819 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1820 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 1821 break;
8990e307 1822
463ee0b2
LW		 1823 case OP_PADAV:
1824 case OP_PADHV:
e4c5ccf3
RH		 1825 if (set_op_ref)
1826 o->op_flags |= OPf_REF;
79072805 1827 break;
aeea060c 1828
8990e307 1829 case OP_SCALAR:
79072805 1830 case OP_NULL:
11343788 1831 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1832 break;
e4c5ccf3 1833 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 1834 break;
1835 case OP_AELEM:
1836 case OP_HELEM:
e4c5ccf3 1837 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 1838 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1839 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1840 : type == OP_RV2HV ? OPpDEREF_HV
1841 : OPpDEREF_SV);
11343788 1842 o->op_flags |= OPf_MOD;
8990e307 1843 }
79072805
LW		 1844 break;
1845
463ee0b2 1846 case OP_SCOPE:
79072805 1847 case OP_LEAVE:
e4c5ccf3
RH		 1848 set_op_ref = FALSE;
1849 /* FALL THROUGH */
79072805 1850 case OP_ENTER:
8990e307 1851 case OP_LIST:
11343788 1852 if (!(o->op_flags & OPf_KIDS))
79072805 1853 break;
e4c5ccf3 1854 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 1855 break;
a0d0e21e
LW		 1856 default:
1857 break;
79072805 1858 }
11343788 1859 return scalar(o);
8990e307 1860
79072805
LW		 1861}
1862
09bef843
SB		 1863STATIC OP *
1864S_dup_attrlist(pTHX_ OP *o)
1865{
97aff369 1866 dVAR;
0bd48802 1867 OP *rop;
09bef843 1868
7918f24d
NC		 1869 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1870
09bef843
SB		 1871 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1872 * where the first kid is OP_PUSHMARK and the remaining ones
1873 * are OP_CONST. We need to push the OP_CONST values.
1874 */
1875 if (o->op_type == OP_CONST)
b37c2d43 1876 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 1877#ifdef PERL_MAD
1878 else if (o->op_type == OP_NULL)
1d866c12 1879 rop = NULL;
eb8433b7 1880#endif
09bef843
SB		 1881 else {
1882 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 1883 rop = NULL;
09bef843
SB		 1884 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1885 if (o->op_type == OP_CONST)
1886 rop = append_elem(OP_LIST, rop,
1887 newSVOP(OP_CONST, o->op_flags,
b37c2d43 1888 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 1889 }
1890 }
1891 return rop;
1892}
1893
1894STATIC void
95f0a2f1 1895S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1896{
27da23d5 1897 dVAR;
09bef843
SB		 1898 SV *stashsv;
1899
7918f24d
NC		 1900 PERL_ARGS_ASSERT_APPLY_ATTRS;
1901
09bef843
SB		 1902 /* fake up C<use attributes $pkg,$rv,@attrs> */
1903 ENTER; /* need to protect against side-effects of 'use' */
5aaec2b4 1904 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 1905
09bef843 1906#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1907#define ATTRSMODULE_PM "attributes.pm"
1908
1909 if (for_my) {
95f0a2f1 1910 /* Don't force the C<use> if we don't need it. */
a4fc7abc 1911 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 1912 if (svp && *svp != &PL_sv_undef)
6f207bd3 1913 NOOP; /* already in %INC */
95f0a2f1
SB		 1914 else
1915 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 1916 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 1917 }
1918 else {
1919 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 1920 newSVpvs(ATTRSMODULE),
1921 NULL,
95f0a2f1
SB		 1922 prepend_elem(OP_LIST,
1923 newSVOP(OP_CONST, 0, stashsv),
1924 prepend_elem(OP_LIST,
1925 newSVOP(OP_CONST, 0,
1926 newRV(target)),
1927 dup_attrlist(attrs))));
1928 }
09bef843
SB		 1929 LEAVE;
1930}
1931
95f0a2f1
SB		 1932STATIC void
1933S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1934{
97aff369 1935 dVAR;
95f0a2f1
SB		 1936 OP *pack, *imop, *arg;
1937 SV *meth, *stashsv;
1938
7918f24d
NC		 1939 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1940
95f0a2f1
SB		 1941 if (!attrs)
1942 return;
1943
1944 assert(target->op_type == OP_PADSV ||
1945 target->op_type == OP_PADHV ||
1946 target->op_type == OP_PADAV);
1947
1948 /* Ensure that attributes.pm is loaded. */
dd2155a4 1949 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 1950
1951 /* Need package name for method call. */
6136c704 1952 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 1953
1954 /* Build up the real arg-list. */
5aaec2b4
NC		 1955 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1956
95f0a2f1
SB		 1957 arg = newOP(OP_PADSV, 0);
1958 arg->op_targ = target->op_targ;
1959 arg = prepend_elem(OP_LIST,
1960 newSVOP(OP_CONST, 0, stashsv),
1961 prepend_elem(OP_LIST,
1962 newUNOP(OP_REFGEN, 0,
1963 mod(arg, OP_REFGEN)),
1964 dup_attrlist(attrs)));
1965
1966 /* Fake up a method call to import */
18916d0d 1967 meth = newSVpvs_share("import");
95f0a2f1
SB		 1968 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1969 append_elem(OP_LIST,
1970 prepend_elem(OP_LIST, pack, list(arg)),
1971 newSVOP(OP_METHOD_NAMED, 0, meth)));
1972 imop->op_private |= OPpENTERSUB_NOMOD;
1973
1974 /* Combine the ops. */
1975 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1976}
1977
1978/*
1979=notfor apidoc apply_attrs_string
1980
1981Attempts to apply a list of attributes specified by the C<attrstr> and
1982C<len> arguments to the subroutine identified by the C<cv> argument which
1983is expected to be associated with the package identified by the C<stashpv>
1984argument (see L<attributes>). It gets this wrong, though, in that it
1985does not correctly identify the boundaries of the individual attribute
1986specifications within C<attrstr>. This is not really intended for the
1987public API, but has to be listed here for systems such as AIX which
1988need an explicit export list for symbols. (It's called from XS code
1989in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1990to respect attribute syntax properly would be welcome.
1991
1992=cut
1993*/
1994
be3174d2 1995void
6867be6d
AL		 1996Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1997 const char *attrstr, STRLEN len)
be3174d2 1998{
5f66b61c 1999 OP *attrs = NULL;
be3174d2 2000
7918f24d
NC		 2001 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2002
be3174d2
GS		 2003 if (!len) {
2004 len = strlen(attrstr);
2005 }
2006
2007 while (len) {
2008 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2009 if (len) {
890ce7af 2010 const char * const sstr = attrstr;
be3174d2
GS		 2011 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2012 attrs = append_elem(OP_LIST, attrs,
2013 newSVOP(OP_CONST, 0,
2014 newSVpvn(sstr, attrstr-sstr)));
2015 }
2016 }
2017
2018 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2019 newSVpvs(ATTRSMODULE),
a0714e2c 2020 NULL, prepend_elem(OP_LIST,
be3174d2
GS		 2021 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2022 prepend_elem(OP_LIST,
2023 newSVOP(OP_CONST, 0,
ad64d0ec 2024 newRV(MUTABLE_SV(cv))),
be3174d2
GS		 2025 attrs)));
2026}
2027
09bef843 2028STATIC OP *
95f0a2f1 2029S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2030{
97aff369 2031 dVAR;
93a17b20
LW		 2032 I32 type;
2033
7918f24d
NC		 2034 PERL_ARGS_ASSERT_MY_KID;
2035
13765c85 2036 if (!o || (PL_parser && PL_parser->error_count))
11343788 2037 return o;
93a17b20 2038
bc61e325 2039 type = o->op_type;
eb8433b7
NC		 2040 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2041 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2042 return o;
2043 }
2044
93a17b20 2045 if (type == OP_LIST) {
6867be6d 2046 OP *kid;
11343788 2047 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2048 my_kid(kid, attrs, imopsp);
eb8433b7
NC		 2049 } else if (type == OP_UNDEF
2050#ifdef PERL_MAD
2051 || type == OP_STUB
2052#endif
2053 ) {
7766148a 2054 return o;
77ca0c92
LW		 2055 } else if (type == OP_RV2SV || /* "our" declaration */
2056 type == OP_RV2AV ||
2057 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2058 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2059 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2060 OP_DESC(o),
12bd6ede
DM		 2061 PL_parser->in_my == KEY_our
2062 ? "our"
2063 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2064 } else if (attrs) {
551405c4 2065 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM		 2066 PL_parser->in_my = FALSE;
2067 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS		 2068 apply_attrs(GvSTASH(gv),
2069 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC		 2070 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2071 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
1ce0b88c
RGS		 2072 attrs, FALSE);
2073 }
192587c2 2074 o->op_private |= OPpOUR_INTRO;
77ca0c92 2075 return o;
95f0a2f1
SB		 2076 }
2077 else if (type != OP_PADSV &&
93a17b20
LW		 2078 type != OP_PADAV &&
2079 type != OP_PADHV &&
2080 type != OP_PUSHMARK)
2081 {
eb64745e 2082 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2083 OP_DESC(o),
12bd6ede
DM		 2084 PL_parser->in_my == KEY_our
2085 ? "our"
2086 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2087 return o;
93a17b20 2088 }
09bef843
SB		 2089 else if (attrs && type != OP_PUSHMARK) {
2090 HV *stash;
09bef843 2091
12bd6ede
DM		 2092 PL_parser->in_my = FALSE;
2093 PL_parser->in_my_stash = NULL;
eb64745e 2094
09bef843 2095 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 2096 stash = PAD_COMPNAME_TYPE(o->op_targ);
2097 if (!stash)
09bef843 2098 stash = PL_curstash;
95f0a2f1 2099 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2100 }
11343788
MB		 2101 o->op_flags |= OPf_MOD;
2102 o->op_private |= OPpLVAL_INTRO;
12bd6ede 2103 if (PL_parser->in_my == KEY_state)
952306ac 2104 o->op_private |= OPpPAD_STATE;
11343788 2105 return o;
93a17b20
LW		 2106}
2107
2108OP *
09bef843
SB		 2109Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2110{
97aff369 2111 dVAR;
0bd48802 2112 OP *rops;
95f0a2f1
SB		 2113 int maybe_scalar = 0;
2114
7918f24d
NC		 2115 PERL_ARGS_ASSERT_MY_ATTRS;
2116
d2be0de5 2117/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2118 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2119#if 0
09bef843
SB		 2120 if (o->op_flags & OPf_PARENS)
2121 list(o);
95f0a2f1
SB		 2122 else
2123 maybe_scalar = 1;
d2be0de5
YST		 2124#else
2125 maybe_scalar = 1;
2126#endif
09bef843
SB		 2127 if (attrs)
2128 SAVEFREEOP(attrs);
5f66b61c 2129 rops = NULL;
95f0a2f1
SB		 2130 o = my_kid(o, attrs, &rops);
2131 if (rops) {
2132 if (maybe_scalar && o->op_type == OP_PADSV) {
2133 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2134 o->op_private |= OPpLVAL_INTRO;
2135 }
2136 else
2137 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2138 }
12bd6ede
DM		 2139 PL_parser->in_my = FALSE;
2140 PL_parser->in_my_stash = NULL;
eb64745e 2141 return o;
09bef843
SB		 2142}
2143
2144OP *
864dbfa3 2145Perl_sawparens(pTHX_ OP *o)
79072805 2146{
96a5add6 2147 PERL_UNUSED_CONTEXT;
79072805
LW		 2148 if (o)
2149 o->op_flags |= OPf_PARENS;
2150 return o;
2151}
2152
2153OP *
864dbfa3 2154Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2155{
11343788 2156 OP *o;
59f00321 2157 bool ismatchop = 0;
1496a290
AL		 2158 const OPCODE ltype = left->op_type;
2159 const OPCODE rtype = right->op_type;
79072805 2160
7918f24d
NC		 2161 PERL_ARGS_ASSERT_BIND_MATCH;
2162
1496a290
AL		 2163 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2164 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2165 {
1496a290 2166 const char * const desc
666ea192
JH		 2167 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2168 ? (int)rtype : OP_MATCH];
2169 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2170 ? "@array" : "%hash");
9014280d 2171 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2172 "Applying %s to %s will act on scalar(%s)",
599cee73 2173 desc, sample, sample);
2ae324a7 2174 }
2175
1496a290 2176 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2177 cSVOPx(right)->op_private & OPpCONST_BARE &&
2178 cSVOPx(right)->op_private & OPpCONST_STRICT)
2179 {
2180 no_bareword_allowed(right);
2181 }
2182
1496a290
AL		 2183 ismatchop = rtype == OP_MATCH ||
2184 rtype == OP_SUBST ||
2185 rtype == OP_TRANS;
59f00321
RGS		 2186 if (ismatchop && right->op_private & OPpTARGET_MY) {
2187 right->op_targ = 0;
2188 right->op_private &= ~OPpTARGET_MY;
2189 }
2190 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2191 OP *newleft;
2192
79072805 2193 right->op_flags |= OPf_STACKED;
1496a290
AL		 2194 if (rtype != OP_MATCH &&
2195 ! (rtype == OP_TRANS &&
6fbb66d6 2196 right->op_private & OPpTRANS_IDENTICAL))
1496a290
AL		 2197 newleft = mod(left, rtype);
2198 else
2199 newleft = left;
79072805 2200 if (right->op_type == OP_TRANS)
1496a290 2201 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2202 else
1496a290 2203 o = prepend_elem(rtype, scalar(newleft), right);
79072805 2204 if (type == OP_NOT)
11343788
MB		 2205 return newUNOP(OP_NOT, 0, scalar(o));
2206 return o;
79072805
LW		 2207 }
2208 else
2209 return bind_match(type, left,
131b3ad0 2210 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 2211}
2212
2213OP *
864dbfa3 2214Perl_invert(pTHX_ OP *o)
79072805 2215{
11343788 2216 if (!o)
1d866c12 2217 return NULL;
11343788 2218 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2219}
2220
2221OP *
864dbfa3 2222Perl_scope(pTHX_ OP *o)
79072805 2223{
27da23d5 2224 dVAR;
79072805 2225 if (o) {
3280af22 2226 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 2227 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2228 o->op_type = OP_LEAVE;
22c35a8c 2229 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2230 }
fdb22418
HS		 2231 else if (o->op_type == OP_LINESEQ) {
2232 OP *kid;
2233 o->op_type = OP_SCOPE;
2234 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2235 kid = ((LISTOP*)o)->op_first;
59110972 2236 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2237 op_null(kid);
59110972
RH		 2238
2239 /* The following deals with things like 'do {1 for 1}' */
2240 kid = kid->op_sibling;
2241 if (kid &&
2242 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2243 op_null(kid);
2244 }
463ee0b2 2245 }
fdb22418 2246 else
5f66b61c 2247 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2248 }
2249 return o;
2250}
72dc9ed5 2251
a0d0e21e 2252int
864dbfa3 2253Perl_block_start(pTHX_ int full)
79072805 2254{
97aff369 2255 dVAR;
73d840c0 2256 const int retval = PL_savestack_ix;
dd2155a4 2257 pad_block_start(full);
b3ac6de7 2258 SAVEHINTS();
3280af22 2259 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2260 SAVECOMPILEWARNINGS();
72dc9ed5 2261 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
a0d0e21e
LW		 2262 return retval;
2263}
2264
2265OP*
864dbfa3 2266Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2267{
97aff369 2268 dVAR;
6867be6d 2269 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
551405c4 2270 OP* const retval = scalarseq(seq);
e9818f4e 2271 LEAVE_SCOPE(floor);
623e6609 2272 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2273 if (needblockscope)
3280af22 2274 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 2275 pad_leavemy();
a0d0e21e
LW		 2276 return retval;
2277}
2278
76e3520e 2279STATIC OP *
cea2e8a9 2280S_newDEFSVOP(pTHX)
54b9620d 2281{
97aff369 2282 dVAR;
9f7d9405 2283 const PADOFFSET offset = pad_findmy("$_");
00b1698f 2284 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2285 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2286 }
2287 else {
551405c4 2288 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2289 o->op_targ = offset;
2290 return o;
2291 }
54b9620d
MB		 2292}
2293
a0d0e21e 2294void
864dbfa3 2295Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2296{
97aff369 2297 dVAR;
7918f24d
NC		 2298
2299 PERL_ARGS_ASSERT_NEWPROG;
2300
3280af22 2301 if (PL_in_eval) {
b295d113
TH		 2302 if (PL_eval_root)
2303 return;
faef0170
HS		 2304 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2305 ((PL_in_eval & EVAL_KEEPERR)
2306 ? OPf_SPECIAL : 0), o);
3280af22 2307 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 2308 PL_eval_root->op_private |= OPpREFCOUNTED;
2309 OpREFCNT_set(PL_eval_root, 1);
3280af22 2310 PL_eval_root->op_next = 0;
a2efc822 2311 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 2312 }
2313 else {
6be89cf9
AE		 2314 if (o->op_type == OP_STUB) {
2315 PL_comppad_name = 0;
2316 PL_compcv = 0;
d2c837a0 2317 S_op_destroy(aTHX_ o);
a0d0e21e 2318 return;
6be89cf9 2319 }
3280af22
NIS		 2320 PL_main_root = scope(sawparens(scalarvoid(o)));
2321 PL_curcop = &PL_compiling;
2322 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2323 PL_main_root->op_private |= OPpREFCOUNTED;
2324 OpREFCNT_set(PL_main_root, 1);
3280af22 2325 PL_main_root->op_next = 0;
a2efc822 2326 CALL_PEEP(PL_main_start);
3280af22 2327 PL_compcv = 0;
3841441e 2328
4fdae800 2329 /* Register with debugger */
84902520 2330 if (PERLDB_INTER) {
b96d8cd9 2331 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS		 2332 if (cv) {
2333 dSP;
924508f0 2334 PUSHMARK(SP);
ad64d0ec 2335 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 2336 PUTBACK;
ad64d0ec 2337 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS		 2338 }
2339 }
79072805 2340 }
79072805
LW		 2341}
2342
2343OP *
864dbfa3 2344Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2345{
97aff369 2346 dVAR;
7918f24d
NC		 2347
2348 PERL_ARGS_ASSERT_LOCALIZE;
2349
79072805 2350 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2351/* [perl #17376]: this appears to be premature, and results in code such as
2352 C< our(%x); > executing in list mode rather than void mode */
2353#if 0
79072805 2354 list(o);
d2be0de5 2355#else
6f207bd3 2356 NOOP;
d2be0de5 2357#endif
8990e307 2358 else {
f06b5848
DM		 2359 if ( PL_parser->bufptr > PL_parser->oldbufptr
2360 && PL_parser->bufptr[-1] == ','
041457d9 2361 && ckWARN(WARN_PARENTHESIS))
64420d0d 2362 {
f06b5848 2363 char *s = PL_parser->bufptr;
bac662ee 2364 bool sigil = FALSE;
64420d0d 2365
8473848f 2366 /* some heuristics to detect a potential error */
bac662ee 2367 while (*s && (strchr(", \t\n", *s)))
64420d0d 2368 s++;
8473848f 2369
bac662ee
TS		 2370 while (1) {
2371 if (*s && strchr("@$%*", *s) && *++s
2372 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2373 s++;
2374 sigil = TRUE;
2375 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2376 s++;
2377 while (*s && (strchr(", \t\n", *s)))
2378 s++;
2379 }
2380 else
2381 break;
2382 }
2383 if (sigil && (*s == ';' || *s == '=')) {
2384 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 2385 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 2386 lex
2387 ? (PL_parser->in_my == KEY_our
2388 ? "our"
2389 : PL_parser->in_my == KEY_state
2390 ? "state"
2391 : "my")
2392 : "local");
8473848f 2393 }
8990e307
LW		 2394 }
2395 }
93a17b20 2396 if (lex)
eb64745e 2397 o = my(o);
93a17b20 2398 else
eb64745e 2399 o = mod(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 2400 PL_parser->in_my = FALSE;
2401 PL_parser->in_my_stash = NULL;
eb64745e 2402 return o;
79072805
LW		 2403}
2404
2405OP *
864dbfa3 2406Perl_jmaybe(pTHX_ OP *o)
79072805 2407{
7918f24d
NC		 2408 PERL_ARGS_ASSERT_JMAYBE;
2409
79072805 2410 if (o->op_type == OP_LIST) {
fafc274c 2411 OP * const o2
d4c19fe8 2412 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
554b3eca 2413 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2414 }
2415 return o;
2416}
2417
1f676739 2418static OP *
b7783a12 2419S_fold_constants(pTHX_ register OP *o)
79072805 2420{
27da23d5 2421 dVAR;
001d637e 2422 register OP * VOL curop;
eb8433b7 2423 OP *newop;
8ea43dc8 2424 VOL I32 type = o->op_type;
e3cbe32f 2425 SV * VOL sv = NULL;
b7f7fd0b
NC		 2426 int ret = 0;
2427 I32 oldscope;
2428 OP *old_next;
5f2d9966
DM		 2429 SV * const oldwarnhook = PL_warnhook;
2430 SV * const olddiehook = PL_diehook;
c427f4d2 2431 COP not_compiling;
b7f7fd0b 2432 dJMPENV;
79072805 2433
7918f24d
NC		 2434 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2435
22c35a8c 2436 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2437 scalar(o);
b162f9ea 2438 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2439 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2440
eac055e9
GS		 2441 /* integerize op, unless it happens to be C<-foo>.
2442 * XXX should pp_i_negate() do magic string negation instead? */
2443 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2444 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2445 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2446 {
22c35a8c 2447 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2448 }
85e6fe83 2449
22c35a8c 2450 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2451 goto nope;
2452
de939608 2453 switch (type) {
7a52d87a
GS		 2454 case OP_NEGATE:
2455 /* XXX might want a ck_negate() for this */
2456 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2457 break;
de939608
CS		 2458 case OP_UCFIRST:
2459 case OP_LCFIRST:
2460 case OP_UC:
2461 case OP_LC:
69dcf70c
MB		 2462 case OP_SLT:
2463 case OP_SGT:
2464 case OP_SLE:
2465 case OP_SGE:
2466 case OP_SCMP:
2de3dbcc
JH		 2467 /* XXX what about the numeric ops? */
2468 if (PL_hints & HINT_LOCALE)
de939608 2469 goto nope;
553e7bb0 2470 break;
de939608
CS		 2471 }
2472
13765c85 2473 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 2474 goto nope; /* Don't try to run w/ errors */
2475
79072805 2476 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 2477 const OPCODE type = curop->op_type;
2478 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2479 type != OP_LIST &&
2480 type != OP_SCALAR &&
2481 type != OP_NULL &&
2482 type != OP_PUSHMARK)
7a52d87a 2483 {
79072805
LW		 2484 goto nope;
2485 }
2486 }
2487
2488 curop = LINKLIST(o);
b7f7fd0b 2489 old_next = o->op_next;
79072805 2490 o->op_next = 0;
533c011a 2491 PL_op = curop;
b7f7fd0b
NC		 2492
2493 oldscope = PL_scopestack_ix;
edb2152a 2494 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 2495
c427f4d2
NC		 2496 /* Verify that we don't need to save it: */
2497 assert(PL_curcop == &PL_compiling);
2498 StructCopy(&PL_compiling, &not_compiling, COP);
2499 PL_curcop = &not_compiling;
2500 /* The above ensures that we run with all the correct hints of the
2501 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2502 assert(IN_PERL_RUNTIME);
5f2d9966
DM		 2503 PL_warnhook = PERL_WARNHOOK_FATAL;
2504 PL_diehook = NULL;
b7f7fd0b
NC		 2505 JMPENV_PUSH(ret);
2506
2507 switch (ret) {
2508 case 0:
2509 CALLRUNOPS(aTHX);
2510 sv = *(PL_stack_sp--);
2511 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2512 pad_swipe(o->op_targ, FALSE);
2513 else if (SvTEMP(sv)) { /* grab mortal temp? */
2514 SvREFCNT_inc_simple_void(sv);
2515 SvTEMP_off(sv);
2516 }
2517 break;
2518 case 3:
2519 /* Something tried to die. Abandon constant folding. */
2520 /* Pretend the error never happened. */
ab69dbc2 2521 CLEAR_ERRSV();
b7f7fd0b
NC		 2522 o->op_next = old_next;
2523 break;
2524 default:
2525 JMPENV_POP;
5f2d9966
DM		 2526 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2527 PL_warnhook = oldwarnhook;
2528 PL_diehook = olddiehook;
2529 /* XXX note that this croak may fail as we've already blown away
2530 * the stack - eg any nested evals */
b7f7fd0b
NC		 2531 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2532 }
b7f7fd0b 2533 JMPENV_POP;
5f2d9966
DM		 2534 PL_warnhook = oldwarnhook;
2535 PL_diehook = olddiehook;
c427f4d2 2536 PL_curcop = &PL_compiling;
edb2152a
NC		 2537
2538 if (PL_scopestack_ix > oldscope)
2539 delete_eval_scope();
eb8433b7 2540
b7f7fd0b
NC		 2541 if (ret)
2542 goto nope;
2543
eb8433b7 2544#ifndef PERL_MAD
79072805 2545 op_free(o);
eb8433b7 2546#endif
de5e01c2 2547 assert(sv);
79072805 2548 if (type == OP_RV2GV)
159b6efe 2549 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 2550 else
ad64d0ec 2551 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
eb8433b7
NC		 2552 op_getmad(o,newop,'f');
2553 return newop;
aeea060c 2554
b7f7fd0b 2555 nope:
79072805
LW		 2556 return o;
2557}
2558
1f676739 2559static OP *
b7783a12 2560S_gen_constant_list(pTHX_ register OP *o)
79072805 2561{
27da23d5 2562 dVAR;
79072805 2563 register OP *curop;
6867be6d 2564 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2565
a0d0e21e 2566 list(o);
13765c85 2567 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 2568 return o; /* Don't attempt to run with errors */
2569
533c011a 2570 PL_op = curop = LINKLIST(o);
a0d0e21e 2571 o->op_next = 0;
a2efc822 2572 CALL_PEEP(curop);
cea2e8a9
GS		 2573 pp_pushmark();
2574 CALLRUNOPS(aTHX);
533c011a 2575 PL_op = curop;
78c72037
NC		 2576 assert (!(curop->op_flags & OPf_SPECIAL));
2577 assert(curop->op_type == OP_RANGE);
cea2e8a9 2578 pp_anonlist();
3280af22 2579 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2580
2581 o->op_type = OP_RV2AV;
22c35a8c 2582 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2583 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2584 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2585 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2586 curop = ((UNOP*)o)->op_first;
b37c2d43 2587 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 2588#ifdef PERL_MAD
2589 op_getmad(curop,o,'O');
2590#else
79072805 2591 op_free(curop);
eb8433b7 2592#endif
79072805
LW		 2593 linklist(o);
2594 return list(o);
2595}
2596
2597OP *
864dbfa3 2598Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2599{
27da23d5 2600 dVAR;
11343788 2601 if (!o || o->op_type != OP_LIST)
5f66b61c 2602 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 2603 else
5dc0d613 2604 o->op_flags &= ~OPf_WANT;
79072805 2605
22c35a8c 2606 if (!(PL_opargs[type] & OA_MARK))
93c66552 2607 op_null(cLISTOPo->op_first);
8990e307 2608
eb160463 2609 o->op_type = (OPCODE)type;
22c35a8c 2610 o->op_ppaddr = PL_ppaddr[type];
11343788 2611 o->op_flags |= flags;
79072805 2612
11343788 2613 o = CHECKOP(type, o);
fe2774ed 2614 if (o->op_type != (unsigned)type)
11343788 2615 return o;
79072805 2616
11343788 2617 return fold_constants(o);
79072805
LW		 2618}
2619
2620/* List constructors */
2621
2622OP *
864dbfa3 2623Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2624{
2625 if (!first)
2626 return last;
8990e307
LW		 2627
2628 if (!last)
79072805 2629 return first;
8990e307 2630
fe2774ed 2631 if (first->op_type != (unsigned)type
155aba94
GS		 2632 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2633 {
2634 return newLISTOP(type, 0, first, last);
2635 }
79072805 2636
a0d0e21e
LW		 2637 if (first->op_flags & OPf_KIDS)
2638 ((LISTOP*)first)->op_last->op_sibling = last;
2639 else {
2640 first->op_flags |= OPf_KIDS;
2641 ((LISTOP*)first)->op_first = last;
2642 }
2643 ((LISTOP*)first)->op_last = last;
a0d0e21e 2644 return first;
79072805
LW		 2645}
2646
2647OP *
864dbfa3 2648Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2649{
2650 if (!first)
2651 return (OP*)last;
8990e307
LW		 2652
2653 if (!last)
79072805 2654 return (OP*)first;
8990e307 2655
fe2774ed 2656 if (first->op_type != (unsigned)type)
79072805 2657 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2658
fe2774ed 2659 if (last->op_type != (unsigned)type)
79072805
LW		 2660 return append_elem(type, (OP*)first, (OP*)last);
2661
2662 first->op_last->op_sibling = last->op_first;
2663 first->op_last = last->op_last;
117dada2 2664 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2665
eb8433b7
NC		 2666#ifdef PERL_MAD
2667 if (last->op_first && first->op_madprop) {
2668 MADPROP *mp = last->op_first->op_madprop;
2669 if (mp) {
2670 while (mp->mad_next)
2671 mp = mp->mad_next;
2672 mp->mad_next = first->op_madprop;
2673 }
2674 else {
2675 last->op_first->op_madprop = first->op_madprop;
2676 }
2677 }
2678 first->op_madprop = last->op_madprop;
2679 last->op_madprop = 0;
2680#endif
2681
d2c837a0 2682 S_op_destroy(aTHX_ (OP*)last);
238a4c30 2683
79072805
LW		 2684 return (OP*)first;
2685}
2686
2687OP *
864dbfa3 2688Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2689{
2690 if (!first)
2691 return last;
8990e307
LW		 2692
2693 if (!last)
79072805 2694 return first;
8990e307 2695
fe2774ed 2696 if (last->op_type == (unsigned)type) {
8990e307
LW		 2697 if (type == OP_LIST) { /* already a PUSHMARK there */
2698 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2699 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2700 if (!(first->op_flags & OPf_PARENS))
2701 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2702 }
2703 else {
2704 if (!(last->op_flags & OPf_KIDS)) {
2705 ((LISTOP*)last)->op_last = first;
2706 last->op_flags |= OPf_KIDS;
2707 }
2708 first->op_sibling = ((LISTOP*)last)->op_first;
2709 ((LISTOP*)last)->op_first = first;
79072805 2710 }
117dada2 2711 last->op_flags |= OPf_KIDS;
79072805
LW		 2712 return last;
2713 }
2714
2715 return newLISTOP(type, 0, first, last);
2716}
2717
2718/* Constructors */
2719
eb8433b7
NC		 2720#ifdef PERL_MAD
2721
2722TOKEN *
2723Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2724{
2725 TOKEN *tk;
99129197 2726 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 2727 tk->tk_type = (OPCODE)optype;
2728 tk->tk_type = 12345;
2729 tk->tk_lval = lval;
2730 tk->tk_mad = madprop;
2731 return tk;
2732}
2733
2734void
2735Perl_token_free(pTHX_ TOKEN* tk)
2736{
7918f24d
NC		 2737 PERL_ARGS_ASSERT_TOKEN_FREE;
2738
eb8433b7
NC		 2739 if (tk->tk_type != 12345)
2740 return;
2741 mad_free(tk->tk_mad);
2742 Safefree(tk);
2743}
2744
2745void
2746Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2747{
2748 MADPROP* mp;
2749 MADPROP* tm;
7918f24d
NC		 2750
2751 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2752
eb8433b7
NC		 2753 if (tk->tk_type != 12345) {
2754 Perl_warner(aTHX_ packWARN(WARN_MISC),
2755 "Invalid TOKEN object ignored");
2756 return;
2757 }
2758 tm = tk->tk_mad;
2759 if (!tm)
2760 return;
2761
2762 /* faked up qw list? */
2763 if (slot == '(' &&
2764 tm->mad_type == MAD_SV &&
d503a9ba 2765 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC		 2766 slot = 'x';
2767
2768 if (o) {
2769 mp = o->op_madprop;
2770 if (mp) {
2771 for (;;) {
2772 /* pretend constant fold didn't happen? */
2773 if (mp->mad_key == 'f' &&
2774 (o->op_type == OP_CONST ||
2775 o->op_type == OP_GV) )
2776 {
2777 token_getmad(tk,(OP*)mp->mad_val,slot);
2778 return;
2779 }
2780 if (!mp->mad_next)
2781 break;
2782 mp = mp->mad_next;
2783 }
2784 mp->mad_next = tm;
2785 mp = mp->mad_next;
2786 }
2787 else {
2788 o->op_madprop = tm;
2789 mp = o->op_madprop;
2790 }
2791 if (mp->mad_key == 'X')
2792 mp->mad_key = slot; /* just change the first one */
2793
2794 tk->tk_mad = 0;
2795 }
2796 else
2797 mad_free(tm);
2798 Safefree(tk);
2799}
2800
2801void
2802Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2803{
2804 MADPROP* mp;
2805 if (!from)
2806 return;
2807 if (o) {
2808 mp = o->op_madprop;
2809 if (mp) {
2810 for (;;) {
2811 /* pretend constant fold didn't happen? */
2812 if (mp->mad_key == 'f' &&
2813 (o->op_type == OP_CONST ||
2814 o->op_type == OP_GV) )
2815 {
2816 op_getmad(from,(OP*)mp->mad_val,slot);
2817 return;
2818 }
2819 if (!mp->mad_next)
2820 break;
2821 mp = mp->mad_next;
2822 }
2823 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2824 }
2825 else {
2826 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2827 }
2828 }
2829}
2830
2831void
2832Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2833{
2834 MADPROP* mp;
2835 if (!from)
2836 return;
2837 if (o) {
2838 mp = o->op_madprop;
2839 if (mp) {
2840 for (;;) {
2841 /* pretend constant fold didn't happen? */
2842 if (mp->mad_key == 'f' &&
2843 (o->op_type == OP_CONST ||
2844 o->op_type == OP_GV) )
2845 {
2846 op_getmad(from,(OP*)mp->mad_val,slot);
2847 return;
2848 }
2849 if (!mp->mad_next)
2850 break;
2851 mp = mp->mad_next;
2852 }
2853 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2854 }
2855 else {
2856 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2857 }
2858 }
2859 else {
99129197
NC		 2860 PerlIO_printf(PerlIO_stderr(),
2861 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 2862 op_free(from);
2863 }
2864}
2865
2866void
2867Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2868{
2869 MADPROP* tm;
2870 if (!mp || !o)
2871 return;
2872 if (slot)
2873 mp->mad_key = slot;
2874 tm = o->op_madprop;
2875 o->op_madprop = mp;
2876 for (;;) {
2877 if (!mp->mad_next)
2878 break;
2879 mp = mp->mad_next;
2880 }
2881 mp->mad_next = tm;
2882}
2883
2884void
2885Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2886{
2887 if (!o)
2888 return;
2889 addmad(tm, &(o->op_madprop), slot);
2890}
2891
2892void
2893Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2894{
2895 MADPROP* mp;
2896 if (!tm || !root)
2897 return;
2898 if (slot)
2899 tm->mad_key = slot;
2900 mp = *root;
2901 if (!mp) {
2902 *root = tm;
2903 return;
2904 }
2905 for (;;) {
2906 if (!mp->mad_next)
2907 break;
2908 mp = mp->mad_next;
2909 }
2910 mp->mad_next = tm;
2911}
2912
2913MADPROP *
2914Perl_newMADsv(pTHX_ char key, SV* sv)
2915{
7918f24d
NC		 2916 PERL_ARGS_ASSERT_NEWMADSV;
2917
eb8433b7
NC		 2918 return newMADPROP(key, MAD_SV, sv, 0);
2919}
2920
2921MADPROP *
d503a9ba 2922Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7
NC		 2923{
2924 MADPROP *mp;
99129197 2925 Newxz(mp, 1, MADPROP);
eb8433b7
NC		 2926 mp->mad_next = 0;
2927 mp->mad_key = key;
2928 mp->mad_vlen = vlen;
2929 mp->mad_type = type;
2930 mp->mad_val = val;
2931/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2932 return mp;
2933}
2934
2935void
2936Perl_mad_free(pTHX_ MADPROP* mp)
2937{
2938/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2939 if (!mp)
2940 return;
2941 if (mp->mad_next)
2942 mad_free(mp->mad_next);
bc177e6b 2943/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC		 2944 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2945 switch (mp->mad_type) {
2946 case MAD_NULL:
2947 break;
2948 case MAD_PV:
2949 Safefree((char*)mp->mad_val);
2950 break;
2951 case MAD_OP:
2952 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2953 op_free((OP*)mp->mad_val);
2954 break;
2955 case MAD_SV:
ad64d0ec 2956 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC		 2957 break;
2958 default:
2959 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2960 break;
2961 }
2962 Safefree(mp);
2963}
2964
2965#endif
2966
79072805 2967OP *
864dbfa3 2968Perl_newNULLLIST(pTHX)
79072805 2969{
8990e307
LW		 2970 return newOP(OP_STUB, 0);
2971}
2972
1f676739 2973static OP *
b7783a12 2974S_force_list(pTHX_ OP *o)
8990e307 2975{
11343788 2976 if (!o || o->op_type != OP_LIST)
5f66b61c 2977 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 2978 op_null(o);
11343788 2979 return o;
79072805
LW		 2980}
2981
2982OP *
864dbfa3 2983Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2984{
27da23d5 2985 dVAR;
79072805
LW		 2986 LISTOP *listop;
2987
b7dc083c 2988 NewOp(1101, listop, 1, LISTOP);
79072805 2989
eb160463 2990 listop->op_type = (OPCODE)type;
22c35a8c 2991 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2992 if (first || last)
2993 flags |= OPf_KIDS;
eb160463 2994 listop->op_flags = (U8)flags;
79072805
LW		 2995
2996 if (!last && first)
2997 last = first;
2998 else if (!first && last)
2999 first = last;
8990e307
LW		 3000 else if (first)
3001 first->op_sibling = last;
79072805
LW		 3002 listop->op_first = first;
3003 listop->op_last = last;
8990e307 3004 if (type == OP_LIST) {
551405c4 3005 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 3006 pushop->op_sibling = first;
3007 listop->op_first = pushop;
3008 listop->op_flags |= OPf_KIDS;
3009 if (!last)
3010 listop->op_last = pushop;
3011 }
79072805 3012
463d09e6 3013 return CHECKOP(type, listop);
79072805
LW		 3014}
3015
3016OP *
864dbfa3 3017Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 3018{
27da23d5 3019 dVAR;
11343788 3020 OP *o;
b7dc083c 3021 NewOp(1101, o, 1, OP);
eb160463 3022 o->op_type = (OPCODE)type;
22c35a8c 3023 o->op_ppaddr = PL_ppaddr[type];
eb160463 3024 o->op_flags = (U8)flags;
670f3923
DM		 3025 o->op_latefree = 0;
3026 o->op_latefreed = 0;
7e5d8ed2 3027 o->op_attached = 0;
79072805 3028
11343788 3029 o->op_next = o;
eb160463 3030 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 3031 if (PL_opargs[type] & OA_RETSCALAR)
11343788 3032 scalar(o);
22c35a8c 3033 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 3034 o->op_targ = pad_alloc(type, SVs_PADTMP);
3035 return CHECKOP(type, o);
79072805
LW		 3036}
3037
3038OP *
864dbfa3 3039Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 3040{
27da23d5 3041 dVAR;
79072805
LW		 3042 UNOP *unop;
3043
93a17b20 3044 if (!first)
aeea060c 3045 first = newOP(OP_STUB, 0);
22c35a8c 3046 if (PL_opargs[type] & OA_MARK)
8990e307 3047 first = force_list(first);
93a17b20 3048
b7dc083c 3049 NewOp(1101, unop, 1, UNOP);
eb160463 3050 unop->op_type = (OPCODE)type;
22c35a8c 3051 unop->op_ppaddr = PL_ppaddr[type];
79072805 3052 unop->op_first = first;
585ec06d 3053 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 3054 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 3055 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 3056 if (unop->op_next)
3057 return (OP*)unop;
3058
a0d0e21e 3059 return fold_constants((OP *) unop);
79072805
LW		 3060}
3061
3062OP *
864dbfa3 3063Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3064{
27da23d5 3065 dVAR;
79072805 3066 BINOP *binop;
b7dc083c 3067 NewOp(1101, binop, 1, BINOP);
79072805
LW		 3068
3069 if (!first)
3070 first = newOP(OP_NULL, 0);
3071
eb160463 3072 binop->op_type = (OPCODE)type;
22c35a8c 3073 binop->op_ppaddr = PL_ppaddr[type];
79072805 3074 binop->op_first = first;
585ec06d 3075 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 3076 if (!last) {
3077 last = first;
eb160463 3078 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3079 }
3080 else {
eb160463 3081 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 3082 first->op_sibling = last;
3083 }
3084
e50aee73 3085 binop = (BINOP*)CHECKOP(type, binop);
eb160463 3086 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 3087 return (OP*)binop;
3088
7284ab6f 3089 binop->op_last = binop->op_first->op_sibling;
79072805 3090
a0d0e21e 3091 return fold_constants((OP *)binop);
79072805
LW		 3092}
3093
5f66b61c
AL		 3094static int uvcompare(const void *a, const void *b)
3095 __attribute__nonnull__(1)
3096 __attribute__nonnull__(2)
3097 __attribute__pure__;
abb2c242 3098static int uvcompare(const void *a, const void *b)
2b9d42f0 3099{
e1ec3a88 3100 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 3101 return -1;
e1ec3a88 3102 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 3103 return 1;
e1ec3a88 3104 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 3105 return -1;
e1ec3a88 3106 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 3107 return 1;
a0ed51b3
LW		 3108 return 0;
3109}
3110
0d86688d
NC		 3111static OP *
3112S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 3113{
97aff369 3114 dVAR;
2d03de9c 3115 SV * const tstr = ((SVOP*)expr)->op_sv;
fbbb0949
DM		 3116 SV * const rstr =
3117#ifdef PERL_MAD
3118 (repl->op_type == OP_NULL)
3119 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3120#endif
3121 ((SVOP*)repl)->op_sv;
463ee0b2
LW		 3122 STRLEN tlen;
3123 STRLEN rlen;
5c144d81
NC		 3124 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3125 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 3126 register I32 i;
3127 register I32 j;
9b877dbb 3128 I32 grows = 0;
79072805
LW		 3129 register short *tbl;
3130
551405c4
AL		 3131 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3132 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3133 I32 del = o->op_private & OPpTRANS_DELETE;
043e41b8 3134 SV* swash;
7918f24d
NC		 3135
3136 PERL_ARGS_ASSERT_PMTRANS;
3137
800b4dc4 3138 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 3139
036b4402
GS		 3140 if (SvUTF8(tstr))
3141 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 3142
3143 if (SvUTF8(rstr))
036b4402 3144 o->op_private |= OPpTRANS_TO_UTF;
79072805 3145
a0ed51b3 3146 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 3147 SV* const listsv = newSVpvs("# comment\n");
c445ea15 3148 SV* transv = NULL;
5c144d81
NC		 3149 const U8* tend = t + tlen;
3150 const U8* rend = r + rlen;
ba210ebe 3151 STRLEN ulen;
84c133a0
RB		 3152 UV tfirst = 1;
3153 UV tlast = 0;
3154 IV tdiff;
3155 UV rfirst = 1;
3156 UV rlast = 0;
3157 IV rdiff;
3158 IV diff;
a0ed51b3
LW		 3159 I32 none = 0;
3160 U32 max = 0;
3161 I32 bits;
a0ed51b3 3162 I32 havefinal = 0;
9c5ffd7c 3163 U32 final = 0;
551405c4
AL		 3164 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3165 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 3166 U8* tsave = NULL;
3167 U8* rsave = NULL;
9f7f3913 3168 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 3169
3170 if (!from_utf) {
3171 STRLEN len = tlen;
5c144d81 3172 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 3173 tend = t + len;
3174 }
3175 if (!to_utf && rlen) {
3176 STRLEN len = rlen;
5c144d81 3177 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 3178 rend = r + len;
3179 }
a0ed51b3 3180
2b9d42f0
NIS		 3181/* There are several snags with this code on EBCDIC:
3182 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3183 2. scan_const() in toke.c has encoded chars in native encoding which makes
3184 ranges at least in EBCDIC 0..255 range the bottom odd.
3185*/
3186
a0ed51b3 3187 if (complement) {
89ebb4a3 3188 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 3189 UV *cp;
a0ed51b3 3190 UV nextmin = 0;
a02a5408 3191 Newx(cp, 2*tlen, UV);
a0ed51b3 3192 i = 0;
396482e1 3193 transv = newSVpvs("");
a0ed51b3 3194 while (t < tend) {
9f7f3913 3195 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS		 3196 t += ulen;
3197 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 3198 t++;
9f7f3913 3199 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 3200 t += ulen;
a0ed51b3 3201 }
2b9d42f0
NIS		 3202 else {
3203 cp[2*i+1] = cp[2*i];
3204 }
3205 i++;
a0ed51b3 3206 }
2b9d42f0 3207 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 3208 for (j = 0; j < i; j++) {
2b9d42f0 3209 UV val = cp[2*j];
a0ed51b3
LW		 3210 diff = val - nextmin;
3211 if (diff > 0) {
9041c2e3 3212 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3213 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 3214 if (diff > 1) {
2b9d42f0 3215 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 3216 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 3217 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 3218 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 3219 }
3220 }
2b9d42f0 3221 val = cp[2*j+1];
a0ed51b3
LW		 3222 if (val >= nextmin)
3223 nextmin = val + 1;
3224 }
9041c2e3 3225 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3226 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 3227 {
3228 U8 range_mark = UTF_TO_NATIVE(0xff);
3229 sv_catpvn(transv, (char *)&range_mark, 1);
3230 }
b851fbc1
JH		 3231 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3232 UNICODE_ALLOW_SUPER);
dfe13c55 3233 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 3234 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 3235 tlen = SvCUR(transv);
3236 tend = t + tlen;
455d824a 3237 Safefree(cp);
a0ed51b3
LW		 3238 }
3239 else if (!rlen && !del) {
3240 r = t; rlen = tlen; rend = tend;
4757a243
LW		 3241 }
3242 if (!squash) {
05d340b8 3243 if ((!rlen && !del) || t == r ||
12ae5dfc 3244 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 3245 {
4757a243 3246 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 3247 }
a0ed51b3
LW		 3248 }
3249
3250 while (t < tend || tfirst <= tlast) {
3251 /* see if we need more "t" chars */
3252 if (tfirst > tlast) {
9f7f3913 3253 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 3254 t += ulen;
2b9d42f0 3255 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3256 t++;
9f7f3913 3257 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW		 3258 t += ulen;
3259 }
3260 else
3261 tlast = tfirst;
3262 }
3263
3264 /* now see if we need more "r" chars */
3265 if (rfirst > rlast) {
3266 if (r < rend) {
9f7f3913 3267 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 3268 r += ulen;
2b9d42f0 3269 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3270 r++;
9f7f3913 3271 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW		 3272 r += ulen;
3273 }
3274 else
3275 rlast = rfirst;
3276 }
3277 else {
3278 if (!havefinal++)
3279 final = rlast;
3280 rfirst = rlast = 0xffffffff;
3281 }
3282 }
3283
3284 /* now see which range will peter our first, if either. */
3285 tdiff = tlast - tfirst;
3286 rdiff = rlast - rfirst;
3287
3288 if (tdiff <= rdiff)
3289 diff = tdiff;
3290 else
3291 diff = rdiff;
3292
3293 if (rfirst == 0xffffffff) {
3294 diff = tdiff; /* oops, pretend rdiff is infinite */
3295 if (diff > 0)
894356b3
GS		 3296 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3297 (long)tfirst, (long)tlast);
a0ed51b3 3298 else
894356b3 3299 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 3300 }
3301 else {
3302 if (diff > 0)
894356b3
GS		 3303 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3304 (long)tfirst, (long)(tfirst + diff),
3305 (long)rfirst);
a0ed51b3 3306 else
894356b3
GS		 3307 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3308 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 3309
3310 if (rfirst + diff > max)
3311 max = rfirst + diff;
9b877dbb 3312 if (!grows)
45005bfb
JH		 3313 grows = (tfirst < rfirst &&
3314 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3315 rfirst += diff + 1;
a0ed51b3
LW		 3316 }
3317 tfirst += diff + 1;
3318 }
3319
3320 none = ++max;
3321 if (del)
3322 del = ++max;
3323
3324 if (max > 0xffff)
3325 bits = 32;
3326 else if (max > 0xff)
3327 bits = 16;
3328 else
3329 bits = 8;
3330
ea71c68d 3331 PerlMemShared_free(cPVOPo->op_pv);
b3123a61 3332 cPVOPo->op_pv = NULL;
043e41b8 3333
ad64d0ec 3334 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
043e41b8
DM		 3335#ifdef USE_ITHREADS
3336 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3337 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3338 PAD_SETSV(cPADOPo->op_padix, swash);
3339 SvPADTMP_on(swash);
a5446a64 3340 SvREADONLY_on(swash);
043e41b8
DM		 3341#else
3342 cSVOPo->op_sv = swash;
3343#endif
a0ed51b3 3344 SvREFCNT_dec(listsv);
b37c2d43 3345 SvREFCNT_dec(transv);
a0ed51b3 3346
45005bfb 3347 if (!del && havefinal && rlen)
85fbaab2 3348 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
b448e4fe 3349 newSVuv((UV)final), 0);
a0ed51b3 3350
9b877dbb 3351 if (grows)
a0ed51b3
LW		 3352 o->op_private |= OPpTRANS_GROWS;
3353
b37c2d43
AL		 3354 Safefree(tsave);
3355 Safefree(rsave);
9b877dbb 3356
eb8433b7
NC		 3357#ifdef PERL_MAD
3358 op_getmad(expr,o,'e');
3359 op_getmad(repl,o,'r');
3360#else
a0ed51b3
LW		 3361 op_free(expr);
3362 op_free(repl);
eb8433b7 3363#endif
a0ed51b3
LW		 3364 return o;
3365 }
3366
3367 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 3368 if (complement) {
3369 Zero(tbl, 256, short);
eb160463 3370 for (i = 0; i < (I32)tlen; i++)
ec49126f 3371 tbl[t[i]] = -1;
79072805
LW		 3372 for (i = 0, j = 0; i < 256; i++) {
3373 if (!tbl[i]) {
eb160463 3374 if (j >= (I32)rlen) {
a0ed51b3 3375 if (del)
79072805
LW		 3376 tbl[i] = -2;
3377 else if (rlen)
ec49126f 3378 tbl[i] = r[j-1];
79072805 3379 else
eb160463 3380 tbl[i] = (short)i;
79072805 3381 }
9b877dbb
IH		 3382 else {
3383 if (i < 128 && r[j] >= 128)
3384 grows = 1;
ec49126f 3385 tbl[i] = r[j++];
9b877dbb 3386 }
79072805
LW		 3387 }
3388 }
05d340b8
JH		 3389 if (!del) {
3390 if (!rlen) {
3391 j = rlen;
3392 if (!squash)
3393 o->op_private |= OPpTRANS_IDENTICAL;
3394 }
eb160463 3395 else if (j >= (I32)rlen)
05d340b8 3396 j = rlen - 1;
10db182f 3397 else {
aa1f7c5b
JH		 3398 tbl =
3399 (short *)
3400 PerlMemShared_realloc(tbl,
3401 (0x101+rlen-j) * sizeof(short));
10db182f
YO		 3402 cPVOPo->op_pv = (char*)tbl;
3403 }
585ec06d 3404 tbl[0x100] = (short)(rlen - j);
eb160463 3405 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 3406 tbl[0x101+i] = r[j+i];
3407 }
79072805
LW		 3408 }
3409 else {
a0ed51b3 3410 if (!rlen && !del) {
79072805 3411 r = t; rlen = tlen;
5d06d08e 3412 if (!squash)
4757a243 3413 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3414 }
94bfe852
RGS		 3415 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3416 o->op_private |= OPpTRANS_IDENTICAL;
3417 }
79072805
LW		 3418 for (i = 0; i < 256; i++)
3419 tbl[i] = -1;
eb160463
GS		 3420 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3421 if (j >= (I32)rlen) {
a0ed51b3 3422 if (del) {
ec49126f 3423 if (tbl[t[i]] == -1)
3424 tbl[t[i]] = -2;
79072805
LW		 3425 continue;
3426 }
3427 --j;
3428 }
9b877dbb
IH		 3429 if (tbl[t[i]] == -1) {
3430 if (t[i] < 128 && r[j] >= 128)
3431 grows = 1;
ec49126f 3432 tbl[t[i]] = r[j];
9b877dbb 3433 }
79072805
LW		 3434 }
3435 }
b08e453b 3436
a2a5de95
NC		 3437 if(del && rlen == tlen) {
3438 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3439 } else if(rlen > tlen) {
3440 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
b08e453b
RB		 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);
a2a5de95
NC		 4546 else if ((cstop->op_private & OPpCONST_BARE))
4547 Perl_ck_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
a2a5de95 4577 && !(o2->op_private & OPpPAD_STATE))
7921d0f2 4578 {
d1d15184
NC		 4579 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4580 "Deprecated use of my() in false conditional");
7921d0f2
DM		 4581 }
4582
5f66b61c 4583 *otherp = NULL;
d6fee5c7
DM		 4584 if (first->op_type == OP_CONST)
4585 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4586 if (PL_madskills) {
4587 first = newUNOP(OP_NULL, 0, first);
4588 op_getmad(other, first, '2');
4589 first->op_targ = type; /* set "was" field */
4590 }
4591 else
4592 op_free(other);
79072805
LW		 4593 return first;
4594 }
4595 }
041457d9
DM		 4596 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4597 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 4598 {
b22e6366
AL		 4599 const OP * const k1 = ((UNOP*)first)->op_first;
4600 const OP * const k2 = k1->op_sibling;
a6006777 4601 OPCODE warnop = 0;
4602 switch (first->op_type)
4603 {
4604 case OP_NULL:
4605 if (k2 && k2->op_type == OP_READLINE
4606 && (k2->op_flags & OPf_STACKED)
1c846c1f 4607 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 4608 {
a6006777 4609 warnop = k2->op_type;
72b16652 4610 }
a6006777 4611 break;
4612
4613 case OP_SASSIGN:
68dc0745 4614 if (k1->op_type == OP_READDIR
4615 || k1->op_type == OP_GLOB
72b16652 4616 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 4617 || k1->op_type == OP_EACH)
72b16652
GS		 4618 {
4619 warnop = ((k1->op_type == OP_NULL)
eb160463 4620 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 4621 }
a6006777 4622 break;
4623 }
8ebc5c01 4624 if (warnop) {
6867be6d 4625 const line_t oldline = CopLINE(PL_curcop);
53a7735b 4626 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 4627 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 4628 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 4629 PL_op_desc[warnop],
68dc0745 4630 ((warnop == OP_READLINE || warnop == OP_GLOB)
4631 ? " construct" : "() operator"));
57843af0 4632 CopLINE_set(PL_curcop, oldline);
8ebc5c01 4633 }
a6006777 4634 }
79072805
LW		 4635
4636 if (!other)
4637 return first;
4638
c963b151 4639 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 4640 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4641
b7dc083c 4642 NewOp(1101, logop, 1, LOGOP);
79072805 4643
eb160463 4644 logop->op_type = (OPCODE)type;
22c35a8c 4645 logop->op_ppaddr = PL_ppaddr[type];
79072805 4646 logop->op_first = first;
585ec06d 4647 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 4648 logop->op_other = LINKLIST(other);
eb160463 4649 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4650
4651 /* establish postfix order */
4652 logop->op_next = LINKLIST(first);
4653 first->op_next = (OP*)logop;
4654 first->op_sibling = other;
4655
463d09e6
RGS		 4656 CHECKOP(type,logop);
4657
edbe35ea 4658 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
11343788 4659 other->op_next = o;
79072805 4660
11343788 4661 return o;
79072805
LW		 4662}
4663
4664OP *
864dbfa3 4665Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 4666{
27da23d5 4667 dVAR;
1a67a97c
SM		 4668 LOGOP *logop;
4669 OP *start;
11343788 4670 OP *o;
71c4dbc3 4671 OP *cstop;
79072805 4672
7918f24d
NC		 4673 PERL_ARGS_ASSERT_NEWCONDOP;
4674
b1cb66bf 4675 if (!falseop)
4676 return newLOGOP(OP_AND, 0, first, trueop);
4677 if (!trueop)
4678 return newLOGOP(OP_OR, 0, first, falseop);
79072805 4679
8990e307 4680 scalarboolean(first);
71c4dbc3 4681 if ((cstop = search_const(first))) {
5b6782b2 4682 /* Left or right arm of the conditional? */
71c4dbc3 4683 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5b6782b2
NC		 4684 OP *live = left ? trueop : falseop;
4685 OP *const dead = left ? falseop : trueop;
71c4dbc3
VP		 4686 if (cstop->op_private & OPpCONST_BARE &&
4687 cstop->op_private & OPpCONST_STRICT) {
4688 no_bareword_allowed(cstop);
b22e6366 4689 }
5b6782b2
NC		 4690 if (PL_madskills) {
4691 /* This is all dead code when PERL_MAD is not defined. */
4692 live = newUNOP(OP_NULL, 0, live);
4693 op_getmad(first, live, 'C');
4694 op_getmad(dead, live, left ? 'e' : 't');
4695 } else {
4696 op_free(first);
4697 op_free(dead);
79072805 4698 }
ef9da979
FC		 4699 if (live->op_type == OP_LEAVE)
4700 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5b6782b2 4701 return live;
79072805 4702 }
1a67a97c
SM		 4703 NewOp(1101, logop, 1, LOGOP);
4704 logop->op_type = OP_COND_EXPR;
4705 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4706 logop->op_first = first;
585ec06d 4707 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 4708 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 4709 logop->op_other = LINKLIST(trueop);
4710 logop->op_next = LINKLIST(falseop);
79072805 4711
463d09e6
RGS		 4712 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4713 logop);
79072805
LW		 4714
4715 /* establish postfix order */
1a67a97c
SM		 4716 start = LINKLIST(first);
4717 first->op_next = (OP*)logop;
79072805 4718
b1cb66bf 4719 first->op_sibling = trueop;
4720 trueop->op_sibling = falseop;
1a67a97c 4721 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 4722
1a67a97c 4723 trueop->op_next = falseop->op_next = o;
79072805 4724
1a67a97c 4725 o->op_next = start;
11343788 4726 return o;
79072805
LW		 4727}
4728
4729OP *
864dbfa3 4730Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 4731{
27da23d5 4732 dVAR;
1a67a97c 4733 LOGOP *range;
79072805
LW		 4734 OP *flip;
4735 OP *flop;
1a67a97c 4736 OP *leftstart;
11343788 4737 OP *o;
79072805 4738
7918f24d
NC		 4739 PERL_ARGS_ASSERT_NEWRANGE;
4740
1a67a97c 4741 NewOp(1101, range, 1, LOGOP);
79072805 4742
1a67a97c
SM		 4743 range->op_type = OP_RANGE;
4744 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4745 range->op_first = left;
4746 range->op_flags = OPf_KIDS;
4747 leftstart = LINKLIST(left);
4748 range->op_other = LINKLIST(right);
eb160463 4749 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4750
4751 left->op_sibling = right;
4752
1a67a97c
SM		 4753 range->op_next = (OP*)range;
4754 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 4755 flop = newUNOP(OP_FLOP, 0, flip);
11343788 4756 o = newUNOP(OP_NULL, 0, flop);
79072805 4757 linklist(flop);
1a67a97c 4758 range->op_next = leftstart;
79072805
LW		 4759
4760 left->op_next = flip;
4761 right->op_next = flop;
4762
1a67a97c
SM		 4763 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4764 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 4765 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 4766 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4767
4768 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4769 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4770
11343788 4771 flip->op_next = o;
79072805 4772 if (!flip->op_private || !flop->op_private)
11343788 4773 linklist(o); /* blow off optimizer unless constant */
79072805 4774
11343788 4775 return o;
79072805
LW		 4776}
4777
4778OP *
864dbfa3 4779Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 4780{
97aff369 4781 dVAR;
463ee0b2 4782 OP* listop;
11343788 4783 OP* o;
73d840c0 4784 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 4785 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 4786
4787 PERL_UNUSED_ARG(debuggable);
93a17b20 4788
463ee0b2
LW		 4789 if (expr) {
4790 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4791 return block; /* do {} while 0 does once */
114c60ec
BG		 4792 if (expr->op_type == OP_READLINE
4793 || expr->op_type == OP_READDIR
4794 || expr->op_type == OP_GLOB
fb73857a 4795 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 4796 expr = newUNOP(OP_DEFINED, 0,
54b9620d 4797 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 4798 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 4799 const OP * const k1 = ((UNOP*)expr)->op_first;
4800 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 4801 switch (expr->op_type) {
1c846c1f 4802 case OP_NULL:
114c60ec 4803 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
55d729e4 4804 && (k2->op_flags & OPf_STACKED)
1c846c1f 4805 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 4806 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 4807 break;
55d729e4
GS		 4808
4809 case OP_SASSIGN:
06dc7ac6 4810 if (k1 && (k1->op_type == OP_READDIR
55d729e4 4811 || k1->op_type == OP_GLOB
6531c3e6 4812 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
06dc7ac6 4813 || k1->op_type == OP_EACH))
55d729e4
GS		 4814 expr = newUNOP(OP_DEFINED, 0, expr);
4815 break;
4816 }
774d564b 4817 }
463ee0b2 4818 }
93a17b20 4819
e1548254
RGS		 4820 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4821 * op, in listop. This is wrong. [perl #27024] */
4822 if (!block)
4823 block = newOP(OP_NULL, 0);
8990e307 4824 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 4825 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 4826
883ffac3
CS		 4827 if (listop)
4828 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 4829
11343788
MB		 4830 if (once && o != listop)
4831 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 4832
11343788
MB		 4833 if (o == listop)
4834 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 4835
11343788
MB		 4836 o->op_flags |= flags;
4837 o = scope(o);
4838 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4839 return o;
79072805
LW		 4840}
4841
4842OP *
a034e688
DM		 4843Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4844whileline, OP *expr, OP *block, OP *cont, I32 has_my)
79072805 4845{
27da23d5 4846 dVAR;
79072805 4847 OP *redo;
c445ea15 4848 OP *next = NULL;
79072805 4849 OP *listop;
11343788 4850 OP *o;
1ba6ee2b 4851 U8 loopflags = 0;
46c461b5
AL		 4852
4853 PERL_UNUSED_ARG(debuggable);
79072805 4854
2d03de9c 4855 if (expr) {
114c60ec
BG		 4856 if (expr->op_type == OP_READLINE
4857 || expr->op_type == OP_READDIR
4858 || expr->op_type == OP_GLOB
2d03de9c
AL		 4859 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4860 expr = newUNOP(OP_DEFINED, 0,
4861 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4862 } else if (expr->op_flags & OPf_KIDS) {
4863 const OP * const k1 = ((UNOP*)expr)->op_first;
4864 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4865 switch (expr->op_type) {
4866 case OP_NULL:
114c60ec 4867 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
2d03de9c
AL		 4868 && (k2->op_flags & OPf_STACKED)
4869 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4870 expr = newUNOP(OP_DEFINED, 0, expr);
4871 break;
55d729e4 4872
2d03de9c 4873 case OP_SASSIGN:
72c8de1a 4874 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 4875 || k1->op_type == OP_GLOB
4876 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
72c8de1a 4877 || k1->op_type == OP_EACH))
2d03de9c
AL		 4878 expr = newUNOP(OP_DEFINED, 0, expr);
4879 break;
4880 }
55d729e4 4881 }
748a9306 4882 }
79072805
LW		 4883
4884 if (!block)
4885 block = newOP(OP_NULL, 0);
a034e688 4886 else if (cont || has_my) {
87246558
GS		 4887 block = scope(block);
4888 }
79072805 4889
1ba6ee2b 4890 if (cont) {
79072805 4891 next = LINKLIST(cont);
1ba6ee2b 4892 }
fb73857a 4893 if (expr) {
551405c4 4894 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 4895 if (!next)
4896 next = unstack;
4897 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 4898 }
79072805 4899
ce3e5c45 4900 assert(block);
463ee0b2 4901 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
ce3e5c45 4902 assert(listop);
79072805
LW		 4903 redo = LINKLIST(listop);
4904
4905 if (expr) {
53a7735b 4906 PL_parser->copline = (line_t)whileline;
883ffac3
CS		 4907 scalar(listop);
4908 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 4909 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 4910 op_free(expr); /* oops, it's a while (0) */
463ee0b2 4911 op_free((OP*)loop);
5f66b61c 4912 return NULL; /* listop already freed by new_logop */
463ee0b2 4913 }
883ffac3 4914 if (listop)
497b47a8 4915 ((LISTOP*)listop)->op_last->op_next =
883ffac3 4916 (o == listop ? redo : LINKLIST(o));
79072805
LW		 4917 }
4918 else
11343788 4919 o = listop;
79072805
LW		 4920
4921 if (!loop) {
b7dc083c 4922 NewOp(1101,loop,1,LOOP);
79072805 4923 loop->op_type = OP_ENTERLOOP;
22c35a8c 4924 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 4925 loop->op_private = 0;
4926 loop->op_next = (OP*)loop;
4927 }
4928
11343788 4929 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 4930
4931 loop->op_redoop = redo;
11343788 4932 loop->op_lastop = o;
1ba6ee2b 4933 o->op_private |= loopflags;
79072805
LW		 4934
4935 if (next)
4936 loop->op_nextop = next;
4937 else
11343788 4938 loop->op_nextop = o;
79072805 4939
11343788
MB		 4940 o->op_flags |= flags;
4941 o->op_private |= (flags >> 8);
4942 return o;
79072805
LW		 4943}
4944
4945OP *
66a1b24b 4946Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
79072805 4947{
27da23d5 4948 dVAR;
79072805 4949 LOOP *loop;
fb73857a 4950 OP *wop;
4bbc6d12 4951 PADOFFSET padoff = 0;
4633a7c4 4952 I32 iterflags = 0;
241416b8 4953 I32 iterpflags = 0;
d4c19fe8 4954 OP *madsv = NULL;
79072805 4955
7918f24d
NC		 4956 PERL_ARGS_ASSERT_NEWFOROP;
4957
79072805 4958 if (sv) {
85e6fe83 4959 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 4960 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 4961 sv->op_type = OP_RV2GV;
22c35a8c 4962 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0be9a6bb
RH		 4963
4964 /* The op_type check is needed to prevent a possible segfault
4965 * if the loop variable is undeclared and 'strict vars' is in
4966 * effect. This is illegal but is nonetheless parsed, so we
4967 * may reach this point with an OP_CONST where we're expecting
4968 * an OP_GV.
4969 */
4970 if (cUNOPx(sv)->op_first->op_type == OP_GV
4971 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
0d863452 4972 iterpflags |= OPpITER_DEF;
79072805 4973 }
85e6fe83 4974 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 4975 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 4976 padoff = sv->op_targ;
eb8433b7
NC		 4977 if (PL_madskills)
4978 madsv = sv;
4979 else {
4980 sv->op_targ = 0;
4981 op_free(sv);
4982 }
5f66b61c 4983 sv = NULL;
85e6fe83 4984 }
79072805 4985 else
cea2e8a9 4986 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
f8503592
NC		 4987 if (padoff) {
4988 SV *const namesv = PAD_COMPNAME_SV(padoff);
4989 STRLEN len;
4990 const char *const name = SvPV_const(namesv, len);
4991
4992 if (len == 2 && name[0] == '$' && name[1] == '_')
4993 iterpflags |= OPpITER_DEF;
4994 }
79072805
LW		 4995 }
4996 else {
9f7d9405 4997 const PADOFFSET offset = pad_findmy("$_");
00b1698f 4998 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 4999 sv = newGVOP(OP_GV, 0, PL_defgv);
5000 }
5001 else {
5002 padoff = offset;
aabe9514 5003 }
0d863452 5004 iterpflags |= OPpITER_DEF;
79072805 5005 }
5f05dabc 5006 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 5007 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 5008 iterflags |= OPf_STACKED;
5009 }
89ea2908
GA		 5010 else if (expr->op_type == OP_NULL &&
5011 (expr->op_flags & OPf_KIDS) &&
5012 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5013 {
5014 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5015 * set the STACKED flag to indicate that these values are to be
5016 * treated as min/max values by 'pp_iterinit'.
5017 */
d4c19fe8 5018 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 5019 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 5020 OP* const left = range->op_first;
5021 OP* const right = left->op_sibling;
5152d7c7 5022 LISTOP* listop;
89ea2908
GA		 5023
5024 range->op_flags &= ~OPf_KIDS;
5f66b61c 5025 range->op_first = NULL;
89ea2908 5026
5152d7c7 5027 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 5028 listop->op_first->op_next = range->op_next;
5029 left->op_next = range->op_other;
5152d7c7
GS		 5030 right->op_next = (OP*)listop;
5031 listop->op_next = listop->op_first;
89ea2908 5032
eb8433b7
NC		 5033#ifdef PERL_MAD
5034 op_getmad(expr,(OP*)listop,'O');
5035#else
89ea2908 5036 op_free(expr);
eb8433b7 5037#endif
5152d7c7 5038 expr = (OP*)(listop);
93c66552 5039 op_null(expr);
89ea2908
GA		 5040 iterflags |= OPf_STACKED;
5041 }
5042 else {
5043 expr = mod(force_list(expr), OP_GREPSTART);
5044 }
5045
4633a7c4 5046 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 5047 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 5048 assert(!loop->op_next);
241416b8 5049 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 5050 * for our $x () sets OPpOUR_INTRO */
c5661c80 5051 loop->op_private = (U8)iterpflags;
b7dc083c 5052#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 5053 {
5054 LOOP *tmp;
5055 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 5056 Copy(loop,tmp,1,LISTOP);
bfafaa29 5057 S_op_destroy(aTHX_ (OP*)loop);
155aba94
GS		 5058 loop = tmp;
5059 }
b7dc083c 5060#else
10edeb5d 5061 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
1c846c1f 5062#endif
85e6fe83 5063 loop->op_targ = padoff;
a034e688 5064 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 5065 if (madsv)
5066 op_getmad(madsv, (OP*)loop, 'v');
53a7735b 5067 PL_parser->copline = forline;
fb73857a 5068 return newSTATEOP(0, label, wop);
79072805
LW		 5069}
5070
8990e307 5071OP*
864dbfa3 5072Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 5073{
97aff369 5074 dVAR;
11343788 5075 OP *o;
2d8e6c8d 5076
7918f24d
NC		 5077 PERL_ARGS_ASSERT_NEWLOOPEX;
5078
8990e307 5079 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 5080 /* "last()" means "last" */
5081 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5082 o = newOP(type, OPf_SPECIAL);
5083 else {
ea71c68d 5084 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4ea561bc 5085 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
666ea192 5086 : ""));
cdaebead 5087 }
eb8433b7
NC		 5088#ifdef PERL_MAD
5089 op_getmad(label,o,'L');
5090#else
8990e307 5091 op_free(label);
eb8433b7 5092#endif
8990e307
LW		 5093 }
5094 else {
e3aba57a
RGS		 5095 /* Check whether it's going to be a goto &function */
5096 if (label->op_type == OP_ENTERSUB
5097 && !(label->op_flags & OPf_STACKED))
a0d0e21e 5098 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 5099 o = newUNOP(type, OPf_STACKED, label);
8990e307 5100 }
3280af22 5101 PL_hints |= HINT_BLOCK_SCOPE;
11343788 5102 return o;
8990e307
LW		 5103}
5104
0d863452
RH		 5105/* if the condition is a literal array or hash
5106 (or @{ ... } etc), make a reference to it.
5107 */
5108STATIC OP *
5109S_ref_array_or_hash(pTHX_ OP *cond)
5110{
5111 if (cond
5112 && (cond->op_type == OP_RV2AV
5113 || cond->op_type == OP_PADAV
5114 || cond->op_type == OP_RV2HV
5115 || cond->op_type == OP_PADHV))
5116
5117 return newUNOP(OP_REFGEN,
5118 0, mod(cond, OP_REFGEN));
5119
5120 else
5121 return cond;
5122}
5123
5124/* These construct the optree fragments representing given()
5125 and when() blocks.
5126
5127 entergiven and enterwhen are LOGOPs; the op_other pointer
5128 points up to the associated leave op. We need this so we
5129 can put it in the context and make break/continue work.
5130 (Also, of course, pp_enterwhen will jump straight to
5131 op_other if the match fails.)
5132 */
5133
4136a0f7 5134STATIC OP *
0d863452
RH		 5135S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5136 I32 enter_opcode, I32 leave_opcode,
5137 PADOFFSET entertarg)
5138{
97aff369 5139 dVAR;
0d863452
RH		 5140 LOGOP *enterop;
5141 OP *o;
5142
7918f24d
NC		 5143 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5144
0d863452 5145 NewOp(1101, enterop, 1, LOGOP);
61a59f30 5146 enterop->op_type = (Optype)enter_opcode;
0d863452
RH		 5147 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5148 enterop->op_flags = (U8) OPf_KIDS;
5149 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5150 enterop->op_private = 0;
5151
5152 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5153
5154 if (cond) {
5155 enterop->op_first = scalar(cond);
5156 cond->op_sibling = block;
5157
5158 o->op_next = LINKLIST(cond);
5159 cond->op_next = (OP *) enterop;
5160 }
5161 else {
5162 /* This is a default {} block */
5163 enterop->op_first = block;
5164 enterop->op_flags |= OPf_SPECIAL;
5165
5166 o->op_next = (OP *) enterop;
5167 }
5168
5169 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5170 entergiven and enterwhen both
5171 use ck_null() */
5172
5173 enterop->op_next = LINKLIST(block);
5174 block->op_next = enterop->op_other = o;
5175
5176 return o;
5177}
5178
5179/* Does this look like a boolean operation? For these purposes
5180 a boolean operation is:
5181 - a subroutine call [*]
5182 - a logical connective
5183 - a comparison operator
5184 - a filetest operator, with the exception of -s -M -A -C
5185 - defined(), exists() or eof()
5186 - /$re/ or $foo =~ /$re/
5187
5188 [*] possibly surprising
5189 */
4136a0f7 5190STATIC bool
ef519e13 5191S_looks_like_bool(pTHX_ const OP *o)
0d863452 5192{
97aff369 5193 dVAR;
7918f24d
NC		 5194
5195 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5196
0d863452
RH		 5197 switch(o->op_type) {
5198 case OP_OR:
f92e1a16 5199 case OP_DOR:
0d863452
RH		 5200 return looks_like_bool(cLOGOPo->op_first);
5201
5202 case OP_AND:
5203 return (
5204 looks_like_bool(cLOGOPo->op_first)
5205 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5206
1e1d4b91
JJ		 5207 case OP_NULL:
5208 return (
5209 o->op_flags & OPf_KIDS
5210 && looks_like_bool(cUNOPo->op_first));
5211
5341b2b7
JJ		 5212 case OP_SCALAR:
5213 return looks_like_bool(cUNOPo->op_first);
5214
5215
0d863452
RH		 5216 case OP_ENTERSUB:
5217
5218 case OP_NOT: case OP_XOR:
0d863452
RH		 5219
5220 case OP_EQ: case OP_NE: case OP_LT:
5221 case OP_GT: case OP_LE: case OP_GE:
5222
5223 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5224 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5225
5226 case OP_SEQ: case OP_SNE: case OP_SLT:
5227 case OP_SGT: case OP_SLE: case OP_SGE:
5228
5229 case OP_SMARTMATCH:
5230
5231 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5232 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5233 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5234 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5235 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5236 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5237 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5238 case OP_FTTEXT: case OP_FTBINARY:
5239
5240 case OP_DEFINED: case OP_EXISTS:
5241 case OP_MATCH: case OP_EOF:
5242
f118ea0d
RGS		 5243 case OP_FLOP:
5244
0d863452
RH		 5245 return TRUE;
5246
5247 case OP_CONST:
5248 /* Detect comparisons that have been optimized away */
5249 if (cSVOPo->op_sv == &PL_sv_yes
5250 || cSVOPo->op_sv == &PL_sv_no)
5251
5252 return TRUE;
6e03d743
RGS		 5253 else
5254 return FALSE;
6e03d743 5255
0d863452
RH		 5256 /* FALL THROUGH */
5257 default:
5258 return FALSE;
5259 }
5260}
5261
5262OP *
5263Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5264{
97aff369 5265 dVAR;
7918f24d 5266 PERL_ARGS_ASSERT_NEWGIVENOP;
0d863452
RH		 5267 return newGIVWHENOP(
5268 ref_array_or_hash(cond),
5269 block,
5270 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5271 defsv_off);
5272}
5273
5274/* If cond is null, this is a default {} block */
5275OP *
5276Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5277{
ef519e13 5278 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 5279 OP *cond_op;
5280
7918f24d
NC		 5281 PERL_ARGS_ASSERT_NEWWHENOP;
5282
0d863452
RH		 5283 if (cond_llb)
5284 cond_op = cond;
5285 else {
5286 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5287 newDEFSVOP(),
5288 scalar(ref_array_or_hash(cond)));
5289 }
5290
5291 return newGIVWHENOP(
5292 cond_op,
5293 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5294 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5295}
5296
7dafbf52
DM		 5297/*
5298=for apidoc cv_undef
5299
5300Clear out all the active components of a CV. This can happen either
5301by an explicit C<undef &foo>, or by the reference count going to zero.
5302In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5303children can still follow the full lexical scope chain.
5304
5305=cut
5306*/
5307
79072805 5308void
864dbfa3 5309Perl_cv_undef(pTHX_ CV *cv)
79072805 5310{
27da23d5 5311 dVAR;
503de470 5312
7918f24d
NC		 5313 PERL_ARGS_ASSERT_CV_UNDEF;
5314
503de470
DM		 5315 DEBUG_X(PerlIO_printf(Perl_debug_log,
5316 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5317 PTR2UV(cv), PTR2UV(PL_comppad))
5318 );
5319
a636914a 5320#ifdef USE_ITHREADS
aed2304a 5321 if (CvFILE(cv) && !CvISXSUB(cv)) {
35f1c1c7 5322 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 5323 Safefree(CvFILE(cv));
a636914a 5324 }
b3123a61 5325 CvFILE(cv) = NULL;
a636914a
RH		 5326#endif
5327
aed2304a 5328 if (!CvISXSUB(cv) && CvROOT(cv)) {
bb172083 5329 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
cea2e8a9 5330 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 5331 ENTER;
a0d0e21e 5332
f3548bdc 5333 PAD_SAVE_SETNULLPAD();
a0d0e21e 5334
282f25c9 5335 op_free(CvROOT(cv));
5f66b61c
AL		 5336 CvROOT(cv) = NULL;
5337 CvSTART(cv) = NULL;
8990e307 5338 LEAVE;
79072805 5339 }
ad64d0ec 5340 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
a0714e2c 5341 CvGV(cv) = NULL;
a3985cdc
DM		 5342
5343 pad_undef(cv);
5344
7dafbf52
DM		 5345 /* remove CvOUTSIDE unless this is an undef rather than a free */
5346 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5347 if (!CvWEAKOUTSIDE(cv))
5348 SvREFCNT_dec(CvOUTSIDE(cv));
601f1833 5349 CvOUTSIDE(cv) = NULL;
7dafbf52 5350 }
beab0874 5351 if (CvCONST(cv)) {
ad64d0ec 5352 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
beab0874
JT		 5353 CvCONST_off(cv);
5354 }
d04ba589 5355 if (CvISXSUB(cv) && CvXSUB(cv)) {
96a5add6 5356 CvXSUB(cv) = NULL;
50762d59 5357 }
7dafbf52
DM		 5358 /* delete all flags except WEAKOUTSIDE */
5359 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 5360}
5361
3fe9a6f1 5362void
cbf82dd0
NC		 5363Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5364 const STRLEN len)
5365{
7918f24d
NC		 5366 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5367
cbf82dd0
NC		 5368 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5369 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5370 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5371 || (p && (len != SvCUR(cv) /* Not the same length. */
5372 || memNE(p, SvPVX_const(cv), len))))
5373 && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 5374 SV* const msg = sv_newmortal();
a0714e2c 5375 SV* name = NULL;
3fe9a6f1 5376
5377 if (gv)
bd61b366 5378 gv_efullname3(name = sv_newmortal(), gv, NULL);
6502358f 5379 sv_setpvs(msg, "Prototype mismatch:");
46fc3d4c 5380 if (name)
be2597df 5381 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
3fe9a6f1 5382 if (SvPOK(cv))
be2597df 5383 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
ebe643b9 5384 else
396482e1
GA		 5385 sv_catpvs(msg, ": none");
5386 sv_catpvs(msg, " vs ");
46fc3d4c 5387 if (p)
cbf82dd0 5388 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
46fc3d4c 5389 else
396482e1 5390 sv_catpvs(msg, "none");
be2597df 5391 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 5392 }
5393}
5394
35f1c1c7
SB		 5395static void const_sv_xsub(pTHX_ CV* cv);
5396
beab0874 5397/*
ccfc67b7
JH		 5398
5399=head1 Optree Manipulation Functions
5400
beab0874
JT		 5401=for apidoc cv_const_sv
5402
5403If C<cv> is a constant sub eligible for inlining. returns the constant
5404value returned by the sub. Otherwise, returns NULL.
5405
5406Constant subs can be created with C<newCONSTSUB> or as described in
5407L<perlsub/"Constant Functions">.
5408
5409=cut
5410*/
760ac839 5411SV *
d45f5b30 5412Perl_cv_const_sv(pTHX_ const CV *const cv)
760ac839 5413{
96a5add6 5414 PERL_UNUSED_CONTEXT;
5069cc75
NC		 5415 if (!cv)
5416 return NULL;
5417 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5418 return NULL;
ad64d0ec 5419 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
fe5e78ed 5420}
760ac839 5421
b5c19bd7
DM		 5422/* op_const_sv: examine an optree to determine whether it's in-lineable.
5423 * Can be called in 3 ways:
5424 *
5425 * !cv
5426 * look for a single OP_CONST with attached value: return the value
5427 *
5428 * cv && CvCLONE(cv) && !CvCONST(cv)
5429 *
5430 * examine the clone prototype, and if contains only a single
5431 * OP_CONST referencing a pad const, or a single PADSV referencing
5432 * an outer lexical, return a non-zero value to indicate the CV is
5433 * a candidate for "constizing" at clone time
5434 *
5435 * cv && CvCONST(cv)
5436 *
5437 * We have just cloned an anon prototype that was marked as a const
5438 * candidiate. Try to grab the current value, and in the case of
5439 * PADSV, ignore it if it has multiple references. Return the value.
5440 */
5441
fe5e78ed 5442SV *
6867be6d 5443Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 5444{
97aff369 5445 dVAR;
a0714e2c 5446 SV *sv = NULL;
fe5e78ed 5447
c631f32b
GG		 5448 if (PL_madskills)
5449 return NULL;
5450
0f79a09d 5451 if (!o)
a0714e2c 5452 return NULL;
1c846c1f
NIS		 5453
5454 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 5455 o = cLISTOPo->op_first->op_sibling;
5456
5457 for (; o; o = o->op_next) {
890ce7af 5458 const OPCODE type = o->op_type;
fe5e78ed 5459
1c846c1f 5460 if (sv && o->op_next == o)
fe5e78ed 5461 return sv;
e576b457
JT		 5462 if (o->op_next != o) {
5463 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5464 continue;
5465 if (type == OP_DBSTATE)
5466 continue;
5467 }
54310121 5468 if (type == OP_LEAVESUB || type == OP_RETURN)
5469 break;
5470 if (sv)
a0714e2c 5471 return NULL;
7766f137 5472 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 5473 sv = cSVOPo->op_sv;
b5c19bd7 5474 else if (cv && type == OP_CONST) {
dd2155a4 5475 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 5476 if (!sv)
a0714e2c 5477 return NULL;
b5c19bd7
DM		 5478 }
5479 else if (cv && type == OP_PADSV) {
5480 if (CvCONST(cv)) { /* newly cloned anon */
5481 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5482 /* the candidate should have 1 ref from this pad and 1 ref
5483 * from the parent */
5484 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 5485 return NULL;
beab0874 5486 sv = newSVsv(sv);
b5c19bd7
DM		 5487 SvREADONLY_on(sv);
5488 return sv;
5489 }
5490 else {
5491 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5492 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 5493 }
760ac839 5494 }
b5c19bd7 5495 else {
a0714e2c 5496 return NULL;
b5c19bd7 5497 }
760ac839
LW		 5498 }
5499 return sv;
5500}
5501
eb8433b7
NC		 5502#ifdef PERL_MAD
5503OP *
5504#else
09bef843 5505void
eb8433b7 5506#endif
09bef843
SB		 5507Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5508{
99129197
NC		 5509#if 0
5510 /* This would be the return value, but the return cannot be reached. */
eb8433b7
NC		 5511 OP* pegop = newOP(OP_NULL, 0);
5512#endif
5513
46c461b5
AL		 5514 PERL_UNUSED_ARG(floor);
5515
09bef843
SB		 5516 if (o)
5517 SAVEFREEOP(o);
5518 if (proto)
5519 SAVEFREEOP(proto);
5520 if (attrs)
5521 SAVEFREEOP(attrs);
5522 if (block)
5523 SAVEFREEOP(block);
5524 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
eb8433b7 5525#ifdef PERL_MAD
99129197 5526 NORETURN_FUNCTION_END;
eb8433b7 5527#endif
09bef843
SB		 5528}
5529
748a9306 5530CV *
864dbfa3 5531Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 5532{
5f66b61c 5533 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
09bef843
SB		 5534}
5535
5536CV *
5537Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5538{
27da23d5 5539 dVAR;
83ee9e09 5540 GV *gv;
5c144d81 5541 const char *ps;
ea6e9374 5542 STRLEN ps_len;
c445ea15 5543 register CV *cv = NULL;
beab0874 5544 SV *const_sv;
b48b272a
NC		 5545 /* If the subroutine has no body, no attributes, and no builtin attributes
5546 then it's just a sub declaration, and we may be able to get away with
5547 storing with a placeholder scalar in the symbol table, rather than a
5548 full GV and CV. If anything is present then it will take a full CV to
5549 store it. */
5550 const I32 gv_fetch_flags
eb8433b7
NC		 5551 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5552 || PL_madskills)
b48b272a 5553 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4ea561bc 5554 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
ed4a8a9b 5555 bool has_name;
8e742a20
MHM		 5556
5557 if (proto) {
5558 assert(proto->op_type == OP_CONST);
4ea561bc 5559 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8e742a20
MHM		 5560 }
5561 else
bd61b366 5562 ps = NULL;
8e742a20 5563
ed4a8a9b
NC		 5564 if (name) {
5565 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5566 has_name = TRUE;
5567 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 5568 SV * const sv = sv_newmortal();
c99da370
JH		 5569 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5570 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 5571 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
ed4a8a9b
NC		 5572 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5573 has_name = TRUE;
c1754fce
NC		 5574 } else if (PL_curstash) {
5575 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 5576 has_name = FALSE;
c1754fce
NC		 5577 } else {
5578 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 5579 has_name = FALSE;
c1754fce 5580 }
83ee9e09 5581
eb8433b7
NC		 5582 if (!PL_madskills) {
5583 if (o)
5584 SAVEFREEOP(o);
5585 if (proto)
5586 SAVEFREEOP(proto);
5587 if (attrs)
5588 SAVEFREEOP(attrs);
5589 }
3fe9a6f1 5590
09bef843 5591 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 5592 maximum a prototype before. */
5593 if (SvTYPE(gv) > SVt_NULL) {
ad64d0ec 5594 if (!SvPOK((const SV *)gv)
9b387841 5595 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
f248d071 5596 {
9b387841 5597 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 5598 }
ea726b52 5599 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
55d729e4
GS		 5600 }
5601 if (ps)
ad64d0ec 5602 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
55d729e4 5603 else
ad64d0ec 5604 sv_setiv(MUTABLE_SV(gv), -1);
e1a479c5 5605
3280af22
NIS		 5606 SvREFCNT_dec(PL_compcv);
5607 cv = PL_compcv = NULL;
beab0874 5608 goto done;
55d729e4
GS		 5609 }
5610
601f1833 5611 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 5612
eb8433b7
NC		 5613 if (!block || !ps || *ps || attrs
5614 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5615#ifdef PERL_MAD
5616 || block->op_type == OP_NULL
5617#endif
5618 )
a0714e2c 5619 const_sv = NULL;
beab0874 5620 else
601f1833 5621 const_sv = op_const_sv(block, NULL);
beab0874
JT		 5622
5623 if (cv) {
6867be6d 5624 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 5625
60ed1d8c
GS		 5626 /* if the subroutine doesn't exist and wasn't pre-declared
5627 * with a prototype, assume it will be AUTOLOADed,
5628 * skipping the prototype check
5629 */
5630 if (exists || SvPOK(cv))
cbf82dd0 5631 cv_ckproto_len(cv, gv, ps, ps_len);
68dc0745 5632 /* already defined (or promised)? */
60ed1d8c 5633 if (exists || GvASSUMECV(gv)) {
eb8433b7
NC		 5634 if ((!block
5635#ifdef PERL_MAD
5636 || block->op_type == OP_NULL
5637#endif
5638 )&& !attrs) {
d3cea301
SB		 5639 if (CvFLAGS(PL_compcv)) {
5640 /* might have had built-in attrs applied */
5641 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5642 }
aa689395 5643 /* just a "sub foo;" when &foo is already defined */
3280af22 5644 SAVEFREESV(PL_compcv);
aa689395 5645 goto done;
5646 }
eb8433b7
NC		 5647 if (block
5648#ifdef PERL_MAD
5649 && block->op_type != OP_NULL
5650#endif
5651 ) {
beab0874
JT		 5652 if (ckWARN(WARN_REDEFINE)
5653 || (CvCONST(cv)
5654 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5655 {
6867be6d 5656 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 5657 if (PL_parser && PL_parser->copline != NOLINE)
5658 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 5659 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 5660 CvCONST(cv) ? "Constant subroutine %s redefined"
5661 : "Subroutine %s redefined", name);
beab0874
JT		 5662 CopLINE_set(PL_curcop, oldline);
5663 }
eb8433b7
NC		 5664#ifdef PERL_MAD
5665 if (!PL_minus_c) /* keep old one around for madskills */
5666#endif
5667 {
5668 /* (PL_madskills unset in used file.) */
5669 SvREFCNT_dec(cv);
5670 }
601f1833 5671 cv = NULL;
79072805 5672 }
79072805
LW		 5673 }
5674 }
beab0874 5675 if (const_sv) {
f84c484e 5676 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 5677 if (cv) {
0768512c 5678 assert(!CvROOT(cv) && !CvCONST(cv));
ad64d0ec 5679 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
beab0874
JT		 5680 CvXSUBANY(cv).any_ptr = const_sv;
5681 CvXSUB(cv) = const_sv_xsub;
5682 CvCONST_on(cv);
d04ba589 5683 CvISXSUB_on(cv);
beab0874
JT		 5684 }
5685 else {
601f1833 5686 GvCV(gv) = NULL;
beab0874
JT		 5687 cv = newCONSTSUB(NULL, name, const_sv);
5688 }
e1a479c5
BB		 5689 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5690 (CvGV(cv) && GvSTASH(CvGV(cv)))
5691 ? GvSTASH(CvGV(cv))
5692 : CvSTASH(cv)
5693 ? CvSTASH(cv)
5694 : PL_curstash
5695 );
eb8433b7
NC		 5696 if (PL_madskills)
5697 goto install_block;
beab0874
JT		 5698 op_free(block);
5699 SvREFCNT_dec(PL_compcv);
5700 PL_compcv = NULL;
beab0874
JT		 5701 goto done;
5702 }
09330df8
Z		 5703 if (cv) { /* must reuse cv if autoloaded */
5704 /* transfer PL_compcv to cv */
5705 if (block
eb8433b7 5706#ifdef PERL_MAD
09330df8 5707 && block->op_type != OP_NULL
eb8433b7 5708#endif
09330df8
Z		 5709 ) {
5710 cv_undef(cv);
5711 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5712 if (!CvWEAKOUTSIDE(cv))
5713 SvREFCNT_dec(CvOUTSIDE(cv));
5714 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5715 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5716 CvOUTSIDE(PL_compcv) = 0;
5717 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5718 CvPADLIST(PL_compcv) = 0;
5719 /* inner references to PL_compcv must be fixed up ... */
5720 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5721 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5722 ++PL_sub_generation;
09bef843
SB		 5723 }
5724 else {
09330df8
Z		 5725 /* Might have had built-in attributes applied -- propagate them. */
5726 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
09bef843 5727 }
282f25c9 5728 /* ... before we throw it away */
3280af22 5729 SvREFCNT_dec(PL_compcv);
b5c19bd7 5730 PL_compcv = cv;
a0d0e21e
LW		 5731 }
5732 else {
3280af22 5733 cv = PL_compcv;
44a8e56a 5734 if (name) {
5735 GvCV(gv) = cv;
eb8433b7
NC		 5736 if (PL_madskills) {
5737 if (strEQ(name, "import")) {
ad64d0ec 5738 PL_formfeed = MUTABLE_SV(cv);
eb8433b7
NC		 5739 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5740 }
5741 }
44a8e56a 5742 GvCVGEN(gv) = 0;
e1a479c5 5743 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
44a8e56a 5744 }
a0d0e21e 5745 }
09330df8
Z		 5746 if (!CvGV(cv)) {
5747 CvGV(cv) = gv;
5748 CvFILE_set_from_cop(cv, PL_curcop);
5749 CvSTASH(cv) = PL_curstash;
5750 }
5751 if (attrs) {
5752 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5753 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5754 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5755 }
8990e307 5756
3fe9a6f1 5757 if (ps)
ad64d0ec 5758 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
4633a7c4 5759
13765c85 5760 if (PL_parser && PL_parser->error_count) {
c07a80fd 5761 op_free(block);
5f66b61c 5762 block = NULL;
68dc0745 5763 if (name) {
6867be6d 5764 const char *s = strrchr(name, ':');
68dc0745 5765 s = s ? s+1 : name;
6d4c2119 5766 if (strEQ(s, "BEGIN")) {
e1ec3a88 5767 const char not_safe[] =
6d4c2119 5768 "BEGIN not safe after errors--compilation aborted";
faef0170 5769 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 5770 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 5771 else {
5772 /* force display of errors found but not reported */
38a03e6e 5773 sv_catpv(ERRSV, not_safe);
be2597df 5774 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6d4c2119
CS		 5775 }
5776 }
68dc0745 5777 }
c07a80fd 5778 }
eb8433b7 5779 install_block:
beab0874
JT		 5780 if (!block)
5781 goto done;
a0d0e21e 5782
aac018bb
NC		 5783 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5784 the debugger could be able to set a breakpoint in, so signal to
5785 pp_entereval that it should not throw away any saved lines at scope
5786 exit. */
5787
fd06b02c 5788 PL_breakable_sub_gen++;
7766f137 5789 if (CvLVALUE(cv)) {
78f9721b
SM		 5790 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5791 mod(scalarseq(block), OP_LEAVESUBLV));
7e5d8ed2 5792 block->op_attached = 1;
7766f137
GS		 5793 }
5794 else {
09c2fd24
AE		 5795 /* This makes sub {}; work as expected. */
5796 if (block->op_type == OP_STUB) {
1496a290 5797 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 5798#ifdef PERL_MAD
5799 op_getmad(block,newblock,'B');
5800#else
09c2fd24 5801 op_free(block);
eb8433b7
NC		 5802#endif
5803 block = newblock;
09c2fd24 5804 }
7e5d8ed2
DM		 5805 else
5806 block->op_attached = 1;
7766f137
GS		 5807 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5808 }
5809 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5810 OpREFCNT_set(CvROOT(cv), 1);
5811 CvSTART(cv) = LINKLIST(CvROOT(cv));
5812 CvROOT(cv)->op_next = 0;
a2efc822 5813 CALL_PEEP(CvSTART(cv));
7766f137
GS		 5814
5815 /* now that optimizer has done its work, adjust pad values */
54310121 5816
dd2155a4
DM		 5817 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5818
5819 if (CvCLONE(cv)) {
beab0874
JT		 5820 assert(!CvCONST(cv));
5821 if (ps && !*ps && op_const_sv(block, cv))
5822 CvCONST_on(cv);
a0d0e21e 5823 }
79072805 5824
ed4a8a9b 5825 if (has_name) {
3280af22 5826 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
561b68a9 5827 SV * const sv = newSV(0);
c4420975 5828 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 5829 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5830 GV_ADDMULTI, SVt_PVHV);
44a8e56a 5831 HV *hv;
5832
ed094faf
GS		 5833 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5834 CopFILE(PL_curcop),
cc49e20b 5835 (long)PL_subline, (long)CopLINE(PL_curcop));
bd61b366 5836 gv_efullname3(tmpstr, gv, NULL);
04fe65b0
RGS		 5837 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5838 SvCUR(tmpstr), sv, 0);
44a8e56a 5839 hv = GvHVn(db_postponed);
551405c4
AL		 5840 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5841 CV * const pcv = GvCV(db_postponed);
5842 if (pcv) {
5843 dSP;
5844 PUSHMARK(SP);
5845 XPUSHs(tmpstr);
5846 PUTBACK;
ad64d0ec 5847 call_sv(MUTABLE_SV(pcv), G_DISCARD);
551405c4 5848 }
44a8e56a 5849 }
5850 }
79072805 5851
13765c85 5852 if (name && ! (PL_parser && PL_parser->error_count))
0cd10f52 5853 process_special_blocks(name, gv, cv);
33fb7a6e 5854 }
ed094faf 5855
33fb7a6e 5856 done:
53a7735b
DM		 5857 if (PL_parser)
5858 PL_parser->copline = NOLINE;
33fb7a6e
NC		 5859 LEAVE_SCOPE(floor);
5860 return cv;
5861}
ed094faf 5862
33fb7a6e
NC		 5863STATIC void
5864S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5865 CV *const cv)
5866{
5867 const char *const colon = strrchr(fullname,':');
5868 const char *const name = colon ? colon + 1 : fullname;
5869
7918f24d
NC		 5870 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5871
33fb7a6e 5872 if (*name == 'B') {
6952d67e 5873 if (strEQ(name, "BEGIN")) {
6867be6d 5874 const I32 oldscope = PL_scopestack_ix;
28757baa 5875 ENTER;
57843af0
GS		 5876 SAVECOPFILE(&PL_compiling);
5877 SAVECOPLINE(&PL_compiling);
28757baa 5878
a58fb6f9 5879 DEBUG_x( dump_sub(gv) );
ad64d0ec 5880 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
ea2f84a3 5881 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 5882 call_list(oldscope, PL_beginav);
a6006777 5883
3280af22 5884 PL_curcop = &PL_compiling;
623e6609 5885 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 5886 LEAVE;
5887 }
33fb7a6e
NC		 5888 else
5889 return;
5890 } else {
5891 if (*name == 'E') {
5892 if strEQ(name, "END") {
a58fb6f9 5893 DEBUG_x( dump_sub(gv) );
ad64d0ec 5894 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
33fb7a6e
NC		 5895 } else
5896 return;
5897 } else if (*name == 'U') {
5898 if (strEQ(name, "UNITCHECK")) {
5899 /* It's never too late to run a unitcheck block */
ad64d0ec 5900 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
33fb7a6e
NC		 5901 }
5902 else
5903 return;
5904 } else if (*name == 'C') {
5905 if (strEQ(name, "CHECK")) {
a2a5de95
NC		 5906 if (PL_main_start)
5907 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5908 "Too late to run CHECK block");
ad64d0ec 5909 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
33fb7a6e
NC		 5910 }
5911 else
5912 return;
5913 } else if (*name == 'I') {
5914 if (strEQ(name, "INIT")) {
a2a5de95
NC		 5915 if (PL_main_start)
5916 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5917 "Too late to run INIT block");
ad64d0ec 5918 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
33fb7a6e
NC		 5919 }
5920 else
5921 return;
5922 } else
5923 return;
a58fb6f9 5924 DEBUG_x( dump_sub(gv) );
33fb7a6e 5925 GvCV(gv) = 0; /* cv has been hijacked */
79072805 5926 }
79072805
LW		 5927}
5928
954c1994
GS		 5929/*
5930=for apidoc newCONSTSUB
5931
5932Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5933eligible for inlining at compile-time.
5934
99ab892b
NC		 5935Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5936which won't be called if used as a destructor, but will suppress the overhead
5937of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5938compile time.)
5939
954c1994
GS		 5940=cut
5941*/
5942
beab0874 5943CV *
e1ec3a88 5944Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5476c433 5945{
27da23d5 5946 dVAR;
beab0874 5947 CV* cv;
cbf82dd0 5948#ifdef USE_ITHREADS
54d012c6 5949 const char *const file = CopFILE(PL_curcop);
cbf82dd0
NC		 5950#else
5951 SV *const temp_sv = CopFILESV(PL_curcop);
def18e4c 5952 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
cbf82dd0 5953#endif
5476c433 5954
11faa288 5955 ENTER;
11faa288 5956
401667e9
DM		 5957 if (IN_PERL_RUNTIME) {
5958 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5959 * an op shared between threads. Use a non-shared COP for our
5960 * dirty work */
5961 SAVEVPTR(PL_curcop);
5962 PL_curcop = &PL_compiling;
5963 }
f4dd75d9 5964 SAVECOPLINE(PL_curcop);
53a7735b 5965 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 5966
5967 SAVEHINTS();
3280af22 5968 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 5969
5970 if (stash) {
5971 SAVESPTR(PL_curstash);
5972 SAVECOPSTASH(PL_curcop);
5973 PL_curstash = stash;
05ec9bb3 5974 CopSTASH_set(PL_curcop,stash);
11faa288 5975 }
5476c433 5976
cbf82dd0
NC		 5977 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5978 and so doesn't get free()d. (It's expected to be from the C pre-
5979 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee 5980 and we need it to get freed. */
54d012c6
NC		 5981 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
5982 XS_DYNAMIC_FILENAME);
beab0874
JT		 5983 CvXSUBANY(cv).any_ptr = sv;
5984 CvCONST_on(cv);
5476c433 5985
65e66c80 5986#ifdef USE_ITHREADS
02f28d44
MHM		 5987 if (stash)
5988 CopSTASH_free(PL_curcop);
65e66c80 5989#endif
11faa288 5990 LEAVE;
beab0874
JT		 5991
5992 return cv;
5476c433
JD		 5993}
5994
77004dee
NC		 5995CV *
5996Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5997 const char *const filename, const char *const proto,
5998 U32 flags)
5999{
6000 CV *cv = newXS(name, subaddr, filename);
6001
7918f24d
NC		 6002 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6003
77004dee
NC		 6004 if (flags & XS_DYNAMIC_FILENAME) {
6005 /* We need to "make arrangements" (ie cheat) to ensure that the
6006 filename lasts as long as the PVCV we just created, but also doesn't
6007 leak */
6008 STRLEN filename_len = strlen(filename);
6009 STRLEN proto_and_file_len = filename_len;
6010 char *proto_and_file;
6011 STRLEN proto_len;
6012
6013 if (proto) {
6014 proto_len = strlen(proto);
6015 proto_and_file_len += proto_len;
6016
6017 Newx(proto_and_file, proto_and_file_len + 1, char);
6018 Copy(proto, proto_and_file, proto_len, char);
6019 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6020 } else {
6021 proto_len = 0;
6022 proto_and_file = savepvn(filename, filename_len);
6023 }
6024
6025 /* This gets free()d. :-) */
ad64d0ec 6026 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
77004dee
NC		 6027 SV_HAS_TRAILING_NUL);
6028 if (proto) {
6029 /* This gives us the correct prototype, rather than one with the
6030 file name appended. */
6031 SvCUR_set(cv, proto_len);
6032 } else {
6033 SvPOK_off(cv);
6034 }
81a2b3b6 6035 CvFILE(cv) = proto_and_file + proto_len;
77004dee 6036 } else {
ad64d0ec 6037 sv_setpv(MUTABLE_SV(cv), proto);
77004dee
NC		 6038 }
6039 return cv;
6040}
6041
954c1994
GS		 6042/*
6043=for apidoc U||newXS
6044
77004dee
NC		 6045Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6046static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 6047
6048=cut
6049*/
6050
57d3b86d 6051CV *
bfed75c6 6052Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 6053{
97aff369 6054 dVAR;
666ea192
JH		 6055 GV * const gv = gv_fetchpv(name ? name :
6056 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6057 GV_ADDMULTI, SVt_PVCV);
79072805 6058 register CV *cv;
44a8e56a 6059
7918f24d
NC		 6060 PERL_ARGS_ASSERT_NEWXS;
6061
1ecdd9a8
HS		 6062 if (!subaddr)
6063 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6064
601f1833 6065 if ((cv = (name ? GvCV(gv) : NULL))) {
44a8e56a 6066 if (GvCVGEN(gv)) {
6067 /* just a cached method */
6068 SvREFCNT_dec(cv);
601f1833 6069 cv = NULL;
44a8e56a 6070 }
6071 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6072 /* already defined (or promised) */
1df70142 6073 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
66a1b24b
AL		 6074 if (ckWARN(WARN_REDEFINE)) {
6075 GV * const gvcv = CvGV(cv);
6076 if (gvcv) {
6077 HV * const stash = GvSTASH(gvcv);
6078 if (stash) {
8b38226b
AL		 6079 const char *redefined_name = HvNAME_get(stash);
6080 if ( strEQ(redefined_name,"autouse") ) {
66a1b24b 6081 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 6082 if (PL_parser && PL_parser->copline != NOLINE)
6083 CopLINE_set(PL_curcop, PL_parser->copline);
66a1b24b 6084 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 6085 CvCONST(cv) ? "Constant subroutine %s redefined"
6086 : "Subroutine %s redefined"
6087 ,name);
66a1b24b
AL		 6088 CopLINE_set(PL_curcop, oldline);
6089 }
6090 }
6091 }
a0d0e21e
LW		 6092 }
6093 SvREFCNT_dec(cv);
601f1833 6094 cv = NULL;
79072805 6095 }
79072805 6096 }
44a8e56a 6097
6098 if (cv) /* must reuse cv if autoloaded */
6099 cv_undef(cv);
a0d0e21e 6100 else {
ea726b52 6101 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
44a8e56a 6102 if (name) {
6103 GvCV(gv) = cv;
6104 GvCVGEN(gv) = 0;
e1a479c5 6105 mro_method_changed_in(GvSTASH(gv)); /* newXS */
44a8e56a 6106 }
a0d0e21e 6107 }
65c50114 6108 CvGV(cv) = gv;
b195d487 6109 (void)gv_fetchfile(filename);
dd374669 6110 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 6111 an external constant string */
d04ba589 6112 CvISXSUB_on(cv);
a0d0e21e 6113 CvXSUB(cv) = subaddr;
44a8e56a 6114
33fb7a6e
NC		 6115 if (name)
6116 process_special_blocks(name, gv, cv);
8990e307 6117 else
a5f75d66 6118 CvANON_on(cv);
44a8e56a 6119
a0d0e21e 6120 return cv;
79072805
LW		 6121}
6122
eb8433b7
NC		 6123#ifdef PERL_MAD
6124OP *
6125#else
79072805 6126void
eb8433b7 6127#endif
864dbfa3 6128Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 6129{
97aff369 6130 dVAR;
79072805 6131 register CV *cv;
eb8433b7
NC		 6132#ifdef PERL_MAD
6133 OP* pegop = newOP(OP_NULL, 0);
6134#endif
79072805 6135
0bd48802 6136 GV * const gv = o
f776e3cd 6137 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 6138 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 6139
a5f75d66 6140 GvMULTI_on(gv);
155aba94 6141 if ((cv = GvFORM(gv))) {
599cee73 6142 if (ckWARN(WARN_REDEFINE)) {
6867be6d 6143 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 6144 if (PL_parser && PL_parser->copline != NOLINE)
6145 CopLINE_set(PL_curcop, PL_parser->copline);
ee6d2783
NC		 6146 if (o) {
6147 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6148 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6149 } else {
6150 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6151 "Format STDOUT redefined");
6152 }
57843af0 6153 CopLINE_set(PL_curcop, oldline);
79072805 6154 }
8990e307 6155 SvREFCNT_dec(cv);
79072805 6156 }
3280af22 6157 cv = PL_compcv;
79072805 6158 GvFORM(gv) = cv;
65c50114 6159 CvGV(cv) = gv;
a636914a 6160 CvFILE_set_from_cop(cv, PL_curcop);
79072805 6161
a0d0e21e 6162
dd2155a4 6163 pad_tidy(padtidy_FORMAT);
79072805 6164 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 6165 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6166 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 6167 CvSTART(cv) = LINKLIST(CvROOT(cv));
6168 CvROOT(cv)->op_next = 0;
a2efc822 6169 CALL_PEEP(CvSTART(cv));
eb8433b7
NC		 6170#ifdef PERL_MAD
6171 op_getmad(o,pegop,'n');
6172 op_getmad_weak(block, pegop, 'b');
6173#else
11343788 6174 op_free(o);
eb8433b7 6175#endif
53a7735b
DM		 6176 if (PL_parser)
6177 PL_parser->copline = NOLINE;
8990e307 6178 LEAVE_SCOPE(floor);
eb8433b7
NC		 6179#ifdef PERL_MAD
6180 return pegop;
6181#endif
79072805
LW		 6182}
6183
6184OP *
864dbfa3 6185Perl_newANONLIST(pTHX_ OP *o)
79072805 6186{
78c72037 6187 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 6188}
6189
6190OP *
864dbfa3 6191Perl_newANONHASH(pTHX_ OP *o)
79072805 6192{
78c72037 6193 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 6194}
6195
6196OP *
864dbfa3 6197Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 6198{
5f66b61c 6199 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 6200}
6201
6202OP *
6203Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6204{
a0d0e21e 6205 return newUNOP(OP_REFGEN, 0,
09bef843 6206 newSVOP(OP_ANONCODE, 0,
ad64d0ec 6207 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
79072805
LW		 6208}
6209
6210OP *
864dbfa3 6211Perl_oopsAV(pTHX_ OP *o)
79072805 6212{
27da23d5 6213 dVAR;
7918f24d
NC		 6214
6215 PERL_ARGS_ASSERT_OOPSAV;
6216
ed6116ce
LW		 6217 switch (o->op_type) {
6218 case OP_PADSV:
6219 o->op_type = OP_PADAV;
22c35a8c 6220 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 6221 return ref(o, OP_RV2AV);
b2ffa427 6222
ed6116ce 6223 case OP_RV2SV:
79072805 6224 o->op_type = OP_RV2AV;
22c35a8c 6225 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 6226 ref(o, OP_RV2AV);
ed6116ce
LW		 6227 break;
6228
6229 default:
9b387841 6230 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 6231 break;
6232 }
79072805
LW		 6233 return o;
6234}
6235
6236OP *
864dbfa3 6237Perl_oopsHV(pTHX_ OP *o)
79072805 6238{
27da23d5 6239 dVAR;
7918f24d
NC		 6240
6241 PERL_ARGS_ASSERT_OOPSHV;
6242
ed6116ce
LW		 6243 switch (o->op_type) {
6244 case OP_PADSV:
6245 case OP_PADAV:
6246 o->op_type = OP_PADHV;
22c35a8c 6247 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 6248 return ref(o, OP_RV2HV);
ed6116ce
LW		 6249
6250 case OP_RV2SV:
6251 case OP_RV2AV:
79072805 6252 o->op_type = OP_RV2HV;
22c35a8c 6253 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 6254 ref(o, OP_RV2HV);
ed6116ce
LW		 6255 break;
6256
6257 default:
9b387841 6258 Perl_ck_warner_d(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 }
a2a5de95 6276 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
d1d15184 6277 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 6278 "Using an array as a reference is deprecated");
a1063b2d 6279 }
79072805
LW		 6280 return newUNOP(OP_RV2AV, 0, scalar(o));
6281}
6282
6283OP *
864dbfa3 6284Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 6285{
82092f1d 6286 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 6287 return newUNOP(OP_NULL, 0, o);
748a9306 6288 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 6289}
6290
6291OP *
864dbfa3 6292Perl_newHVREF(pTHX_ OP *o)
79072805 6293{
27da23d5 6294 dVAR;
7918f24d
NC		 6295
6296 PERL_ARGS_ASSERT_NEWHVREF;
6297
ed6116ce
LW		 6298 if (o->op_type == OP_PADANY) {
6299 o->op_type = OP_PADHV;
22c35a8c 6300 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 6301 return o;
ed6116ce 6302 }
a2a5de95 6303 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
d1d15184 6304 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 6305 "Using a hash as a reference is deprecated");
a1063b2d 6306 }
79072805
LW		 6307 return newUNOP(OP_RV2HV, 0, scalar(o));
6308}
6309
6310OP *
864dbfa3 6311Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 6312{
c07a80fd 6313 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 6314}
6315
6316OP *
864dbfa3 6317Perl_newSVREF(pTHX_ OP *o)
79072805 6318{
27da23d5 6319 dVAR;
7918f24d
NC		 6320
6321 PERL_ARGS_ASSERT_NEWSVREF;
6322
ed6116ce
LW		 6323 if (o->op_type == OP_PADANY) {
6324 o->op_type = OP_PADSV;
22c35a8c 6325 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 6326 return o;
ed6116ce 6327 }
79072805
LW		 6328 return newUNOP(OP_RV2SV, 0, scalar(o));
6329}
6330
61b743bb
DM		 6331/* Check routines. See the comments at the top of this file for details
6332 * on when these are called */
79072805
LW		 6333
6334OP *
cea2e8a9 6335Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 6336{
7918f24d
NC		 6337 PERL_ARGS_ASSERT_CK_ANONCODE;
6338
dd2155a4 6339 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
eb8433b7 6340 if (!PL_madskills)
1d866c12 6341 cSVOPo->op_sv = NULL;
5dc0d613 6342 return o;
5f05dabc 6343}
6344
6345OP *
cea2e8a9 6346Perl_ck_bitop(pTHX_ OP *o)
55497cff 6347{
97aff369 6348 dVAR;
7918f24d
NC		 6349
6350 PERL_ARGS_ASSERT_CK_BITOP;
6351
276b2a0c
RGS		 6352#define OP_IS_NUMCOMPARE(op) \
6353 ((op) == OP_LT || (op) == OP_I_LT || \
6354 (op) == OP_GT || (op) == OP_I_GT || \
6355 (op) == OP_LE || (op) == OP_I_LE || \
6356 (op) == OP_GE || (op) == OP_I_GE || \
6357 (op) == OP_EQ || (op) == OP_I_EQ || \
6358 (op) == OP_NE || (op) == OP_I_NE || \
6359 (op) == OP_NCMP || (op) == OP_I_NCMP)
d5ec2987 6360 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 6361 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6362 && (o->op_type == OP_BIT_OR
6363 || o->op_type == OP_BIT_AND
6364 || o->op_type == OP_BIT_XOR))
276b2a0c 6365 {
1df70142
AL		 6366 const OP * const left = cBINOPo->op_first;
6367 const OP * const right = left->op_sibling;
96a925ab
YST		 6368 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6369 (left->op_flags & OPf_PARENS) == 0) ||
6370 (OP_IS_NUMCOMPARE(right->op_type) &&
6371 (right->op_flags & OPf_PARENS) == 0))
a2a5de95
NC		 6372 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6373 "Possible precedence problem on bitwise %c operator",
6374 o->op_type == OP_BIT_OR ? '|'
6375 : o->op_type == OP_BIT_AND ? '&' : '^'
6376 );
276b2a0c 6377 }
5dc0d613 6378 return o;
55497cff 6379}
6380
6381OP *
cea2e8a9 6382Perl_ck_concat(pTHX_ OP *o)
79072805 6383{
0bd48802 6384 const OP * const kid = cUNOPo->op_first;
7918f24d
NC		 6385
6386 PERL_ARGS_ASSERT_CK_CONCAT;
96a5add6 6387 PERL_UNUSED_CONTEXT;
7918f24d 6388
df91b2c5
AE		 6389 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6390 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 6391 o->op_flags |= OPf_STACKED;
11343788 6392 return o;
79072805
LW		 6393}
6394
6395OP *
cea2e8a9 6396Perl_ck_spair(pTHX_ OP *o)
79072805 6397{
27da23d5 6398 dVAR;
7918f24d
NC		 6399
6400 PERL_ARGS_ASSERT_CK_SPAIR;
6401
11343788 6402 if (o->op_flags & OPf_KIDS) {
79072805 6403 OP* newop;
a0d0e21e 6404 OP* kid;
6867be6d 6405 const OPCODE type = o->op_type;
5dc0d613 6406 o = modkids(ck_fun(o), type);
11343788 6407 kid = cUNOPo->op_first;
a0d0e21e 6408 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 6409 if (newop) {
6410 const OPCODE type = newop->op_type;
6411 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6412 type == OP_PADAV || type == OP_PADHV ||
6413 type == OP_RV2AV || type == OP_RV2HV)
6414 return o;
a0d0e21e 6415 }
eb8433b7
NC		 6416#ifdef PERL_MAD
6417 op_getmad(kUNOP->op_first,newop,'K');
6418#else
a0d0e21e 6419 op_free(kUNOP->op_first);
eb8433b7 6420#endif
a0d0e21e
LW		 6421 kUNOP->op_first = newop;
6422 }
22c35a8c 6423 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 6424 return ck_fun(o);
a0d0e21e
LW		 6425}
6426
6427OP *
cea2e8a9 6428Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 6429{
7918f24d
NC		 6430 PERL_ARGS_ASSERT_CK_DELETE;
6431
11343788 6432 o = ck_fun(o);
5dc0d613 6433 o->op_private = 0;
11343788 6434 if (o->op_flags & OPf_KIDS) {
551405c4 6435 OP * const kid = cUNOPo->op_first;
01020589
GS		 6436 switch (kid->op_type) {
6437 case OP_ASLICE:
6438 o->op_flags |= OPf_SPECIAL;
6439 /* FALL THROUGH */
6440 case OP_HSLICE:
5dc0d613 6441 o->op_private |= OPpSLICE;
01020589
GS		 6442 break;
6443 case OP_AELEM:
6444 o->op_flags |= OPf_SPECIAL;
6445 /* FALL THROUGH */
6446 case OP_HELEM:
6447 break;
6448 default:
6449 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 6450 OP_DESC(o));
01020589 6451 }
7332a6c4
VP		 6452 if (kid->op_private & OPpLVAL_INTRO)
6453 o->op_private |= OPpLVAL_INTRO;
93c66552 6454 op_null(kid);
79072805 6455 }
11343788 6456 return o;
79072805
LW		 6457}
6458
6459OP *
96e176bf
CL		 6460Perl_ck_die(pTHX_ OP *o)
6461{
7918f24d
NC		 6462 PERL_ARGS_ASSERT_CK_DIE;
6463
96e176bf
CL		 6464#ifdef VMS
6465 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6466#endif
6467 return ck_fun(o);
6468}
6469
6470OP *
cea2e8a9 6471Perl_ck_eof(pTHX_ OP *o)
79072805 6472{
97aff369 6473 dVAR;
79072805 6474
7918f24d
NC		 6475 PERL_ARGS_ASSERT_CK_EOF;
6476
11343788
MB		 6477 if (o->op_flags & OPf_KIDS) {
6478 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 6479 OP * const newop
6480 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 6481#ifdef PERL_MAD
6482 op_getmad(o,newop,'O');
6483#else
11343788 6484 op_free(o);
eb8433b7
NC		 6485#endif
6486 o = newop;
8990e307 6487 }
11343788 6488 return ck_fun(o);
79072805 6489 }
11343788 6490 return o;
79072805
LW		 6491}
6492
6493OP *
cea2e8a9 6494Perl_ck_eval(pTHX_ OP *o)
79072805 6495{
27da23d5 6496 dVAR;
7918f24d
NC		 6497
6498 PERL_ARGS_ASSERT_CK_EVAL;
6499
3280af22 6500 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6501 if (o->op_flags & OPf_KIDS) {
46c461b5 6502 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 6503
93a17b20 6504 if (!kid) {
11343788 6505 o->op_flags &= ~OPf_KIDS;
93c66552 6506 op_null(o);
79072805 6507 }
b14574b4 6508 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 6509 LOGOP *enter;
eb8433b7 6510#ifdef PERL_MAD
1d866c12 6511 OP* const oldo = o;
eb8433b7 6512#endif
79072805 6513
11343788 6514 cUNOPo->op_first = 0;
eb8433b7 6515#ifndef PERL_MAD
11343788 6516 op_free(o);
eb8433b7 6517#endif
79072805 6518
b7dc083c 6519 NewOp(1101, enter, 1, LOGOP);
79072805 6520 enter->op_type = OP_ENTERTRY;
22c35a8c 6521 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 6522 enter->op_private = 0;
6523
6524 /* establish postfix order */
6525 enter->op_next = (OP*)enter;
6526
3a7a94e2
RGS		 6527 CHECKOP(OP_ENTERTRY, enter);
6528
11343788
MB		 6529 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6530 o->op_type = OP_LEAVETRY;
22c35a8c 6531 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 6532 enter->op_other = o;
eb8433b7 6533 op_getmad(oldo,o,'O');
11343788 6534 return o;
79072805 6535 }
b5c19bd7 6536 else {
473986ff 6537 scalar((OP*)kid);
b5c19bd7
DM		 6538 PL_cv_has_eval = 1;
6539 }
79072805
LW		 6540 }
6541 else {
eb8433b7 6542#ifdef PERL_MAD
1d866c12 6543 OP* const oldo = o;
eb8433b7 6544#else
11343788 6545 op_free(o);
eb8433b7 6546#endif
54b9620d 6547 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
eb8433b7 6548 op_getmad(oldo,o,'O');
79072805 6549 }
3280af22 6550 o->op_targ = (PADOFFSET)PL_hints;
7168684c 6551 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
996c9baa
VP		 6552 /* Store a copy of %^H that pp_entereval can pick up. */
6553 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
ad64d0ec 6554 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
0d863452
RH		 6555 cUNOPo->op_first->op_sibling = hhop;
6556 o->op_private |= OPpEVAL_HAS_HH;
6557 }
11343788 6558 return o;
79072805
LW		 6559}
6560
6561OP *
d98f61e7
GS		 6562Perl_ck_exit(pTHX_ OP *o)
6563{
7918f24d
NC		 6564 PERL_ARGS_ASSERT_CK_EXIT;
6565
d98f61e7 6566#ifdef VMS
551405c4 6567 HV * const table = GvHV(PL_hintgv);
d98f61e7 6568 if (table) {
a4fc7abc 6569 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 6570 if (svp && *svp && SvTRUE(*svp))
6571 o->op_private |= OPpEXIT_VMSISH;
6572 }
96e176bf 6573 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 6574#endif
6575 return ck_fun(o);
6576}
6577
6578OP *
cea2e8a9 6579Perl_ck_exec(pTHX_ OP *o)
79072805 6580{
7918f24d
NC		 6581 PERL_ARGS_ASSERT_CK_EXEC;
6582
11343788 6583 if (o->op_flags & OPf_STACKED) {
6867be6d 6584 OP *kid;
11343788
MB		 6585 o = ck_fun(o);
6586 kid = cUNOPo->op_first->op_sibling;
8990e307 6587 if (kid->op_type == OP_RV2GV)
93c66552 6588 op_null(kid);
79072805 6589 }
463ee0b2 6590 else
11343788
MB		 6591 o = listkids(o);
6592 return o;
79072805
LW		 6593}
6594
6595OP *
cea2e8a9 6596Perl_ck_exists(pTHX_ OP *o)
5f05dabc 6597{
97aff369 6598 dVAR;
7918f24d
NC		 6599
6600 PERL_ARGS_ASSERT_CK_EXISTS;
6601
5196be3e
MB		 6602 o = ck_fun(o);
6603 if (o->op_flags & OPf_KIDS) {
46c461b5 6604 OP * const kid = cUNOPo->op_first;
afebc493
GS		 6605 if (kid->op_type == OP_ENTERSUB) {
6606 (void) ref(kid, o->op_type);
13765c85
DM		 6607 if (kid->op_type != OP_RV2CV
6608 && !(PL_parser && PL_parser->error_count))
afebc493 6609 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 6610 OP_DESC(o));
afebc493
GS		 6611 o->op_private |= OPpEXISTS_SUB;
6612 }
6613 else if (kid->op_type == OP_AELEM)
01020589
GS		 6614 o->op_flags |= OPf_SPECIAL;
6615 else if (kid->op_type != OP_HELEM)
b0fdf69e 6616 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
53e06cf0 6617 OP_DESC(o));
93c66552 6618 op_null(kid);
5f05dabc 6619 }
5196be3e 6620 return o;
5f05dabc 6621}
6622
79072805 6623OP *
cea2e8a9 6624Perl_ck_rvconst(pTHX_ register OP *o)
79072805 6625{
27da23d5 6626 dVAR;
0bd48802 6627 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 6628
7918f24d
NC		 6629 PERL_ARGS_ASSERT_CK_RVCONST;
6630
3280af22 6631 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 6632 if (o->op_type == OP_RV2CV)
6633 o->op_private &= ~1;
6634
79072805 6635 if (kid->op_type == OP_CONST) {
44a8e56a 6636 int iscv;
6637 GV *gv;
504618e9 6638 SV * const kidsv = kid->op_sv;
44a8e56a 6639
779c5bc9
GS		 6640 /* Is it a constant from cv_const_sv()? */
6641 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 6642 SV * const rsv = SvRV(kidsv);
42d0e0b7 6643 const svtype type = SvTYPE(rsv);
bd61b366 6644 const char *badtype = NULL;
779c5bc9
GS		 6645
6646 switch (o->op_type) {
6647 case OP_RV2SV:
42d0e0b7 6648 if (type > SVt_PVMG)
779c5bc9
GS		 6649 badtype = "a SCALAR";
6650 break;
6651 case OP_RV2AV:
42d0e0b7 6652 if (type != SVt_PVAV)
779c5bc9
GS		 6653 badtype = "an ARRAY";
6654 break;
6655 case OP_RV2HV:
42d0e0b7 6656 if (type != SVt_PVHV)
779c5bc9 6657 badtype = "a HASH";
779c5bc9
GS		 6658 break;
6659 case OP_RV2CV:
42d0e0b7 6660 if (type != SVt_PVCV)
779c5bc9
GS		 6661 badtype = "a CODE";
6662 break;
6663 }
6664 if (badtype)
cea2e8a9 6665 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 6666 return o;
6667 }
ce10b5d1
RGS		 6668 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6669 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6670 /* If this is an access to a stash, disable "strict refs", because
6671 * stashes aren't auto-vivified at compile-time (unless we store
6672 * symbols in them), and we don't want to produce a run-time
6673 * stricture error when auto-vivifying the stash. */
6674 const char *s = SvPV_nolen(kidsv);
6675 const STRLEN l = SvCUR(kidsv);
6676 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6677 o->op_private &= ~HINT_STRICT_REFS;
6678 }
6679 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 6680 const char *badthing;
5dc0d613 6681 switch (o->op_type) {
44a8e56a 6682 case OP_RV2SV:
6683 badthing = "a SCALAR";
6684 break;
6685 case OP_RV2AV:
6686 badthing = "an ARRAY";
6687 break;
6688 case OP_RV2HV:
6689 badthing = "a HASH";
6690 break;
5f66b61c
AL		 6691 default:
6692 badthing = NULL;
6693 break;
44a8e56a 6694 }
6695 if (badthing)
1c846c1f 6696 Perl_croak(aTHX_
95b63a38 6697 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 6698 SVfARG(kidsv), badthing);
44a8e56a 6699 }
93233ece
CS		 6700 /*
6701 * This is a little tricky. We only want to add the symbol if we
6702 * didn't add it in the lexer. Otherwise we get duplicate strict
6703 * warnings. But if we didn't add it in the lexer, we must at
6704 * least pretend like we wanted to add it even if it existed before,
6705 * or we get possible typo warnings. OPpCONST_ENTERED says
6706 * whether the lexer already added THIS instance of this symbol.
6707 */
5196be3e 6708 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 6709 do {
7a5fd60d 6710 gv = gv_fetchsv(kidsv,
748a9306 6711 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 6712 iscv
6713 ? SVt_PVCV
11343788 6714 : o->op_type == OP_RV2SV
a0d0e21e 6715 ? SVt_PV
11343788 6716 : o->op_type == OP_RV2AV
a0d0e21e 6717 ? SVt_PVAV
11343788 6718 : o->op_type == OP_RV2HV
a0d0e21e
LW		 6719 ? SVt_PVHV
6720 : SVt_PVGV);
93233ece
CS		 6721 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6722 if (gv) {
6723 kid->op_type = OP_GV;
6724 SvREFCNT_dec(kid->op_sv);
350de78d 6725#ifdef USE_ITHREADS
638eceb6 6726 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 6727 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 6728 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 6729 GvIN_PAD_on(gv);
ad64d0ec 6730 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
350de78d 6731#else
b37c2d43 6732 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 6733#endif
23f1ca44 6734 kid->op_private = 0;
76cd736e 6735 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 6736 }
79072805 6737 }
11343788 6738 return o;
79072805
LW		 6739}
6740
6741OP *
cea2e8a9 6742Perl_ck_ftst(pTHX_ OP *o)
79072805 6743{
27da23d5 6744 dVAR;
6867be6d 6745 const I32 type = o->op_type;
79072805 6746
7918f24d
NC		 6747 PERL_ARGS_ASSERT_CK_FTST;
6748
d0dca557 6749 if (o->op_flags & OPf_REF) {
6f207bd3 6750 NOOP;
d0dca557
JD		 6751 }
6752 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 6753 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 6754 const OPCODE kidtype = kid->op_type;
79072805 6755
1496a290 6756 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 6757 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 6758 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 6759#ifdef PERL_MAD
6760 op_getmad(o,newop,'O');
6761#else
11343788 6762 op_free(o);
eb8433b7 6763#endif
1d866c12 6764 return newop;
79072805 6765 }
6ecf81d6 6766 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
1af34c76 6767 o->op_private |= OPpFT_ACCESS;
1496a290
AL		 6768 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6769 && kidtype != OP_STAT && kidtype != OP_LSTAT)
fbb0b3b3 6770 o->op_private |= OPpFT_STACKED;
79072805
LW		 6771 }
6772 else {
eb8433b7 6773#ifdef PERL_MAD
1d866c12 6774 OP* const oldo = o;
eb8433b7 6775#else
11343788 6776 op_free(o);
eb8433b7 6777#endif
79072805 6778 if (type == OP_FTTTY)
8fde6460 6779 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 6780 else
d0dca557 6781 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 6782 op_getmad(oldo,o,'O');
79072805 6783 }
11343788 6784 return o;
79072805
LW		 6785}
6786
6787OP *
cea2e8a9 6788Perl_ck_fun(pTHX_ OP *o)
79072805 6789{
97aff369 6790 dVAR;
6867be6d 6791 const int type = o->op_type;
22c35a8c 6792 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 6793
7918f24d
NC		 6794 PERL_ARGS_ASSERT_CK_FUN;
6795
11343788 6796 if (o->op_flags & OPf_STACKED) {
79072805
LW		 6797 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6798 oa &= ~OA_OPTIONAL;
6799 else
11343788 6800 return no_fh_allowed(o);
79072805
LW		 6801 }
6802
11343788 6803 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 6804 OP **tokid = &cLISTOPo->op_first;
6805 register OP *kid = cLISTOPo->op_first;
6806 OP *sibl;
6807 I32 numargs = 0;
6808
8990e307 6809 if (kid->op_type == OP_PUSHMARK ||
155aba94 6810 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 6811 {
79072805
LW		 6812 tokid = &kid->op_sibling;
6813 kid = kid->op_sibling;
6814 }
22c35a8c 6815 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 6816 *tokid = kid = newDEFSVOP();
79072805
LW		 6817
6818 while (oa && kid) {
6819 numargs++;
6820 sibl = kid->op_sibling;
eb8433b7
NC		 6821#ifdef PERL_MAD
6822 if (!sibl && kid->op_type == OP_STUB) {
6823 numargs--;
6824 break;
6825 }
6826#endif
79072805
LW		 6827 switch (oa & 7) {
6828 case OA_SCALAR:
62c18ce2
GS		 6829 /* list seen where single (scalar) arg expected? */
6830 if (numargs == 1 && !(oa >> 4)
6831 && kid->op_type == OP_LIST && type != OP_SCALAR)
6832 {
6833 return too_many_arguments(o,PL_op_desc[type]);
6834 }
79072805
LW		 6835 scalar(kid);
6836 break;
6837 case OA_LIST:
6838 if (oa < 16) {
6839 kid = 0;
6840 continue;
6841 }
6842 else
6843 list(kid);
6844 break;
6845 case OA_AVREF:
936edb8b 6846 if ((type == OP_PUSH || type == OP_UNSHIFT)
a2a5de95
NC		 6847 && !kid->op_sibling)
6848 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6849 "Useless use of %s with no values",
6850 PL_op_desc[type]);
b2ffa427 6851
79072805 6852 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6853 (kid->op_private & OPpCONST_BARE))
6854 {
551405c4 6855 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 6856 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
d1d15184 6857 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 6858 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6859 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6860#ifdef PERL_MAD
6861 op_getmad(kid,newop,'K');
6862#else
79072805 6863 op_free(kid);
eb8433b7 6864#endif
79072805
LW		 6865 kid = newop;
6866 kid->op_sibling = sibl;
6867 *tokid = kid;
6868 }
8990e307 6869 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 6870 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 6871 mod(kid, type);
79072805
LW		 6872 break;
6873 case OA_HVREF:
6874 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6875 (kid->op_private & OPpCONST_BARE))
6876 {
551405c4 6877 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 6878 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
d1d15184 6879 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95
NC		 6880 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6881 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6882#ifdef PERL_MAD
6883 op_getmad(kid,newop,'K');
6884#else
79072805 6885 op_free(kid);
eb8433b7 6886#endif
79072805
LW		 6887 kid = newop;
6888 kid->op_sibling = sibl;
6889 *tokid = kid;
6890 }
8990e307 6891 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 6892 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 6893 mod(kid, type);
79072805
LW		 6894 break;
6895 case OA_CVREF:
6896 {
551405c4 6897 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 6898 kid->op_sibling = 0;
6899 linklist(kid);
6900 newop->op_next = newop;
6901 kid = newop;
6902 kid->op_sibling = sibl;
6903 *tokid = kid;
6904 }
6905 break;
6906 case OA_FILEREF:
c340be78 6907 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 6908 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6909 (kid->op_private & OPpCONST_BARE))
6910 {
0bd48802 6911 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 6912 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 6913 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 6914 kid == cLISTOPo->op_last)
364daeac 6915 cLISTOPo->op_last = newop;
eb8433b7
NC		 6916#ifdef PERL_MAD
6917 op_getmad(kid,newop,'K');
6918#else
79072805 6919 op_free(kid);
eb8433b7 6920#endif
79072805
LW		 6921 kid = newop;
6922 }
1ea32a52
GS		 6923 else if (kid->op_type == OP_READLINE) {
6924 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 6925 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 6926 }
79072805 6927 else {
35cd451c 6928 I32 flags = OPf_SPECIAL;
a6c40364 6929 I32 priv = 0;
2c8ac474
GS		 6930 PADOFFSET targ = 0;
6931
35cd451c 6932 /* is this op a FH constructor? */
853846ea 6933 if (is_handle_constructor(o,numargs)) {
bd61b366 6934 const char *name = NULL;
dd2155a4 6935 STRLEN len = 0;
2c8ac474
GS		 6936
6937 flags = 0;
6938 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 6939 * need to "prove" flag does not mean something
6940 * else already - NI-S 1999/05/07
2c8ac474
GS		 6941 */
6942 priv = OPpDEREF;
6943 if (kid->op_type == OP_PADSV) {
f8503592
NC		 6944 SV *const namesv
6945 = PAD_COMPNAME_SV(kid->op_targ);
6946 name = SvPV_const(namesv, len);
2c8ac474
GS		 6947 }
6948 else if (kid->op_type == OP_RV2SV
6949 && kUNOP->op_first->op_type == OP_GV)
6950 {
0bd48802 6951 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 6952 name = GvNAME(gv);
6953 len = GvNAMELEN(gv);
6954 }
afd1915d
GS		 6955 else if (kid->op_type == OP_AELEM
6956 || kid->op_type == OP_HELEM)
6957 {
735fec84 6958 OP *firstop;
551405c4 6959 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 6960 name = NULL;
551405c4 6961 if (op) {
a0714e2c 6962 SV *tmpstr = NULL;
551405c4 6963 const char * const a =
666ea192
JH		 6964 kid->op_type == OP_AELEM ?
6965 "[]" : "{}";
0c4b0a3f
JH		 6966 if (((op->op_type == OP_RV2AV) ||
6967 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 6968 (firstop = ((UNOP*)op)->op_first) &&
6969 (firstop->op_type == OP_GV)) {
0c4b0a3f 6970 /* packagevar $a[] or $h{} */
735fec84 6971 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 6972 if (gv)
6973 tmpstr =
6974 Perl_newSVpvf(aTHX_
6975 "%s%c...%c",
6976 GvNAME(gv),
6977 a[0], a[1]);
6978 }
6979 else if (op->op_type == OP_PADAV
6980 || op->op_type == OP_PADHV) {
6981 /* lexicalvar $a[] or $h{} */
551405c4 6982 const char * const padname =
0c4b0a3f
JH		 6983 PAD_COMPNAME_PV(op->op_targ);
6984 if (padname)
6985 tmpstr =
6986 Perl_newSVpvf(aTHX_
6987 "%s%c...%c",
6988 padname + 1,
6989 a[0], a[1]);
0c4b0a3f
JH		 6990 }
6991 if (tmpstr) {
93524f2b 6992 name = SvPV_const(tmpstr, len);
0c4b0a3f
JH		 6993 sv_2mortal(tmpstr);
6994 }
6995 }
6996 if (!name) {
6997 name = "__ANONIO__";
6998 len = 10;
6999 }
7000 mod(kid, type);
afd1915d 7001 }
2c8ac474
GS		 7002 if (name) {
7003 SV *namesv;
7004 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 7005 namesv = PAD_SVl(targ);
862a34c6 7006 SvUPGRADE(namesv, SVt_PV);
2c8ac474 7007 if (*name != '$')
76f68e9b 7008 sv_setpvs(namesv, "$");
2c8ac474
GS		 7009 sv_catpvn(namesv, name, len);
7010 }
853846ea 7011 }
79072805 7012 kid->op_sibling = 0;
35cd451c 7013 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 7014 kid->op_targ = targ;
7015 kid->op_private |= priv;
79072805
LW		 7016 }
7017 kid->op_sibling = sibl;
7018 *tokid = kid;
7019 }
7020 scalar(kid);
7021 break;
7022 case OA_SCALARREF:
a0d0e21e 7023 mod(scalar(kid), type);
79072805
LW		 7024 break;
7025 }
7026 oa >>= 4;
7027 tokid = &kid->op_sibling;
7028 kid = kid->op_sibling;
7029 }
eb8433b7
NC		 7030#ifdef PERL_MAD
7031 if (kid && kid->op_type != OP_STUB)
7032 return too_many_arguments(o,OP_DESC(o));
7033 o->op_private |= numargs;
7034#else
7035 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 7036 o->op_private |= numargs;
79072805 7037 if (kid)
53e06cf0 7038 return too_many_arguments(o,OP_DESC(o));
eb8433b7 7039#endif
11343788 7040 listkids(o);
79072805 7041 }
22c35a8c 7042 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 7043#ifdef PERL_MAD
c7fe699d 7044 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 7045 op_getmad(o,newop,'O');
c7fe699d 7046 return newop;
c56915e3 7047#else
c7fe699d 7048 /* Ordering of these two is important to keep f_map.t passing. */
11343788 7049 op_free(o);
c7fe699d 7050 return newUNOP(type, 0, newDEFSVOP());
c56915e3 7051#endif
a0d0e21e
LW		 7052 }
7053
79072805
LW		 7054 if (oa) {
7055 while (oa & OA_OPTIONAL)
7056 oa >>= 4;
7057 if (oa && oa != OA_LIST)
53e06cf0 7058 return too_few_arguments(o,OP_DESC(o));
79072805 7059 }
11343788 7060 return o;
79072805
LW		 7061}
7062
7063OP *
cea2e8a9 7064Perl_ck_glob(pTHX_ OP *o)
79072805 7065{
27da23d5 7066 dVAR;
fb73857a 7067 GV *gv;
7068
7918f24d
NC		 7069 PERL_ARGS_ASSERT_CK_GLOB;
7070
649da076 7071 o = ck_fun(o);
1f2bfc8a 7072 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 7073 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 7074
fafc274c 7075 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 7076 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7077 {
5c1737d1 7078 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 7079 }
b1cb66bf 7080
52bb0670 7081#if !defined(PERL_EXTERNAL_GLOB)
72b16652 7082 /* XXX this can be tightened up and made more failsafe. */
f444d496 7083 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 7084 GV *glob_gv;
72b16652 7085 ENTER;
00ca71c1 7086 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
a0714e2c 7087 newSVpvs("File::Glob"), NULL, NULL, NULL);
5c1737d1
NC		 7088 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7089 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7d3fb230 7090 GvCV(gv) = GvCV(glob_gv);
ad64d0ec 7091 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7d3fb230 7092 GvIMPORTED_CV_on(gv);
72b16652
GS		 7093 LEAVE;
7094 }
52bb0670 7095#endif /* PERL_EXTERNAL_GLOB */
72b16652 7096
b9f751c0 7097 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 7098 append_elem(OP_GLOB, o,
80252599 7099 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 7100 o->op_type = OP_LIST;
22c35a8c 7101 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 7102 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 7103 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 7104 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 7105 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 7106 append_elem(OP_LIST, o,
1f2bfc8a
MB		 7107 scalar(newUNOP(OP_RV2CV, 0,
7108 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 7109 o = newUNOP(OP_NULL, 0, ck_subr(o));
7110 o->op_targ = OP_GLOB; /* hint at what it used to be */
7111 return o;
b1cb66bf 7112 }
7113 gv = newGVgen("main");
a0d0e21e 7114 gv_IOadd(gv);
11343788
MB		 7115 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7116 scalarkids(o);
649da076 7117 return o;
79072805
LW		 7118}
7119
7120OP *
cea2e8a9 7121Perl_ck_grep(pTHX_ OP *o)
79072805 7122{
27da23d5 7123 dVAR;
03ca120d 7124 LOGOP *gwop = NULL;
79072805 7125 OP *kid;
6867be6d 7126 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 7127 PADOFFSET offset;
79072805 7128
7918f24d
NC		 7129 PERL_ARGS_ASSERT_CK_GREP;
7130
22c35a8c 7131 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 7132 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 7133
11343788 7134 if (o->op_flags & OPf_STACKED) {
a0d0e21e 7135 OP* k;
11343788
MB		 7136 o = ck_sort(o);
7137 kid = cLISTOPo->op_first->op_sibling;
d09ad856
BS		 7138 if (!cUNOPx(kid)->op_next)
7139 Perl_croak(aTHX_ "panic: ck_grep");
e3c9a8b9 7140 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
a0d0e21e
LW		 7141 kid = k;
7142 }
03ca120d 7143 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 7144 kid->op_next = (OP*)gwop;
11343788 7145 o->op_flags &= ~OPf_STACKED;
93a17b20 7146 }
11343788 7147 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 7148 if (type == OP_MAPWHILE)
7149 list(kid);
7150 else
7151 scalar(kid);
11343788 7152 o = ck_fun(o);
13765c85 7153 if (PL_parser && PL_parser->error_count)
11343788 7154 return o;
aeea060c 7155 kid = cLISTOPo->op_first->op_sibling;
79072805 7156 if (kid->op_type != OP_NULL)
cea2e8a9 7157 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 7158 kid = kUNOP->op_first;
7159
03ca120d
MHM		 7160 if (!gwop)
7161 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 7162 gwop->op_type = type;
22c35a8c 7163 gwop->op_ppaddr = PL_ppaddr[type];
11343788 7164 gwop->op_first = listkids(o);
79072805 7165 gwop->op_flags |= OPf_KIDS;
79072805 7166 gwop->op_other = LINKLIST(kid);
79072805 7167 kid->op_next = (OP*)gwop;
59f00321 7168 offset = pad_findmy("$_");
00b1698f 7169 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 7170 o->op_private = gwop->op_private = 0;
7171 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7172 }
7173 else {
7174 o->op_private = gwop->op_private = OPpGREP_LEX;
7175 gwop->op_targ = o->op_targ = offset;
7176 }
79072805 7177
11343788 7178 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 7179 if (!kid || !kid->op_sibling)
53e06cf0 7180 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 7181 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7182 mod(kid, OP_GREPSTART);
7183
79072805
LW		 7184 return (OP*)gwop;
7185}
7186
7187OP *
cea2e8a9 7188Perl_ck_index(pTHX_ OP *o)
79072805 7189{
7918f24d
NC		 7190 PERL_ARGS_ASSERT_CK_INDEX;
7191
11343788
MB		 7192 if (o->op_flags & OPf_KIDS) {
7193 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 7194 if (kid)
7195 kid = kid->op_sibling; /* get past "big" */
79072805 7196 if (kid && kid->op_type == OP_CONST)
2779dcf1 7197 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 7198 }
11343788 7199 return ck_fun(o);
79072805
LW		 7200}
7201
7202OP *
cea2e8a9 7203Perl_ck_lfun(pTHX_ OP *o)
79072805 7204{
6867be6d 7205 const OPCODE type = o->op_type;
7918f24d
NC		 7206
7207 PERL_ARGS_ASSERT_CK_LFUN;
7208
5dc0d613 7209 return modkids(ck_fun(o), type);
79072805
LW		 7210}
7211
7212OP *
cea2e8a9 7213Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 7214{
7918f24d
NC		 7215 PERL_ARGS_ASSERT_CK_DEFINED;
7216
a2a5de95 7217 if ((o->op_flags & OPf_KIDS)) {
d0334bed
GS		 7218 switch (cUNOPo->op_first->op_type) {
7219 case OP_RV2AV:
a8739d98
JH		 7220 /* This is needed for
7221 if (defined %stash::)
7222 to work. Do not break Tk.
7223 */
1c846c1f 7224 break; /* Globals via GV can be undef */
d0334bed
GS		 7225 case OP_PADAV:
7226 case OP_AASSIGN: /* Is this a good idea? */
d1d15184 7227 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7228 "defined(@array) is deprecated");
d1d15184 7229 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7230 "\t(Maybe you should just omit the defined()?)\n");
69794302 7231 break;
d0334bed
GS		 7232 case OP_RV2HV:
7233 case OP_PADHV:
d1d15184 7234 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7235 "defined(%%hash) is deprecated");
d1d15184 7236 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
a2a5de95 7237 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 7238 break;
7239 default:
7240 /* no warning */
7241 break;
7242 }
69794302
MJD		 7243 }
7244 return ck_rfun(o);
7245}
7246
7247OP *
e4b7ebf3
RGS		 7248Perl_ck_readline(pTHX_ OP *o)
7249{
7918f24d
NC		 7250 PERL_ARGS_ASSERT_CK_READLINE;
7251
e4b7ebf3
RGS		 7252 if (!(o->op_flags & OPf_KIDS)) {
7253 OP * const newop
7254 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7255#ifdef PERL_MAD
7256 op_getmad(o,newop,'O');
7257#else
7258 op_free(o);
7259#endif
7260 return newop;
7261 }
7262 return o;
7263}
7264
7265OP *
cea2e8a9 7266Perl_ck_rfun(pTHX_ OP *o)
8990e307 7267{
6867be6d 7268 const OPCODE type = o->op_type;
7918f24d
NC		 7269
7270 PERL_ARGS_ASSERT_CK_RFUN;
7271
5dc0d613 7272 return refkids(ck_fun(o), type);
8990e307
LW		 7273}
7274
7275OP *
cea2e8a9 7276Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 7277{
7278 register OP *kid;
aeea060c 7279
7918f24d
NC		 7280 PERL_ARGS_ASSERT_CK_LISTIOB;
7281
11343788 7282 kid = cLISTOPo->op_first;
79072805 7283 if (!kid) {
11343788
MB		 7284 o = force_list(o);
7285 kid = cLISTOPo->op_first;
79072805
LW		 7286 }
7287 if (kid->op_type == OP_PUSHMARK)
7288 kid = kid->op_sibling;
11343788 7289 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 7290 kid = kid->op_sibling;
7291 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7292 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 7293 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 7294 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 7295 cLISTOPo->op_first->op_sibling = kid;
7296 cLISTOPo->op_last = kid;
79072805
LW		 7297 kid = kid->op_sibling;
7298 }
7299 }
b2ffa427 7300
79072805 7301 if (!kid)
54b9620d 7302 append_elem(o->op_type, o, newDEFSVOP());
79072805 7303
2de3dbcc 7304 return listkids(o);
bbce6d69 7305}
7306
7307OP *
0d863452
RH		 7308Perl_ck_smartmatch(pTHX_ OP *o)
7309{
97aff369 7310 dVAR;
0d863452
RH		 7311 if (0 == (o->op_flags & OPf_SPECIAL)) {
7312 OP *first = cBINOPo->op_first;
7313 OP *second = first->op_sibling;
7314
7315 /* Implicitly take a reference to an array or hash */
5f66b61c 7316 first->op_sibling = NULL;
0d863452
RH		 7317 first = cBINOPo->op_first = ref_array_or_hash(first);
7318 second = first->op_sibling = ref_array_or_hash(second);
7319
7320 /* Implicitly take a reference to a regular expression */
7321 if (first->op_type == OP_MATCH) {
7322 first->op_type = OP_QR;
7323 first->op_ppaddr = PL_ppaddr[OP_QR];
7324 }
7325 if (second->op_type == OP_MATCH) {
7326 second->op_type = OP_QR;
7327 second->op_ppaddr = PL_ppaddr[OP_QR];
7328 }
7329 }
7330
7331 return o;
7332}
7333
7334
7335OP *
b162f9ea
IZ		 7336Perl_ck_sassign(pTHX_ OP *o)
7337{
3088bf26 7338 dVAR;
1496a290 7339 OP * const kid = cLISTOPo->op_first;
7918f24d
NC		 7340
7341 PERL_ARGS_ASSERT_CK_SASSIGN;
7342
b162f9ea
IZ		 7343 /* has a disposable target? */
7344 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 7345 && !(kid->op_flags & OPf_STACKED)
7346 /* Cannot steal the second time! */
1b438339
GG		 7347 && !(kid->op_private & OPpTARGET_MY)
7348 /* Keep the full thing for madskills */
7349 && !PL_madskills
7350 )
b162f9ea 7351 {
551405c4 7352 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 7353
7354 /* Can just relocate the target. */
2c2d71f5
JH		 7355 if (kkid && kkid->op_type == OP_PADSV
7356 && !(kkid->op_private & OPpLVAL_INTRO))
7357 {
b162f9ea 7358 kid->op_targ = kkid->op_targ;
743e66e6 7359 kkid->op_targ = 0;
b162f9ea
IZ		 7360 /* Now we do not need PADSV and SASSIGN. */
7361 kid->op_sibling = o->op_sibling; /* NULL */
7362 cLISTOPo->op_first = NULL;
7363 op_free(o);
7364 op_free(kkid);
7365 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7366 return kid;
7367 }
7368 }
c5917253
NC		 7369 if (kid->op_sibling) {
7370 OP *kkid = kid->op_sibling;
7371 if (kkid->op_type == OP_PADSV
7372 && (kkid->op_private & OPpLVAL_INTRO)
7373 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7374 const PADOFFSET target = kkid->op_targ;
7375 OP *const other = newOP(OP_PADSV,
7376 kkid->op_flags
7377 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7378 OP *const first = newOP(OP_NULL, 0);
7379 OP *const nullop = newCONDOP(0, first, o, other);
7380 OP *const condop = first->op_next;
7381 /* hijacking PADSTALE for uninitialized state variables */
7382 SvPADSTALE_on(PAD_SVl(target));
7383
7384 condop->op_type = OP_ONCE;
7385 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7386 condop->op_targ = target;
7387 other->op_targ = target;
7388
95562366
NC		 7389 /* Because we change the type of the op here, we will skip the
7390 assinment binop->op_last = binop->op_first->op_sibling; at the
7391 end of Perl_newBINOP(). So need to do it here. */
7392 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7393
c5917253
NC		 7394 return nullop;
7395 }
7396 }
b162f9ea
IZ		 7397 return o;
7398}
7399
7400OP *
cea2e8a9 7401Perl_ck_match(pTHX_ OP *o)
79072805 7402{
97aff369 7403 dVAR;
7918f24d
NC		 7404
7405 PERL_ARGS_ASSERT_CK_MATCH;
7406
0d863452 7407 if (o->op_type != OP_QR && PL_compcv) {
9f7d9405 7408 const PADOFFSET offset = pad_findmy("$_");
00b1698f 7409 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 7410 o->op_targ = offset;
7411 o->op_private |= OPpTARGET_MY;
7412 }
7413 }
7414 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7415 o->op_private |= OPpRUNTIME;
11343788 7416 return o;
79072805
LW		 7417}
7418
7419OP *
f5d5a27c
CS		 7420Perl_ck_method(pTHX_ OP *o)
7421{
551405c4 7422 OP * const kid = cUNOPo->op_first;
7918f24d
NC		 7423
7424 PERL_ARGS_ASSERT_CK_METHOD;
7425
f5d5a27c
CS		 7426 if (kid->op_type == OP_CONST) {
7427 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 7428 const char * const method = SvPVX_const(sv);
7429 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 7430 OP *cmop;
1c846c1f 7431 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
a4fc7abc 7432 sv = newSVpvn_share(method, SvCUR(sv), 0);
1c846c1f
NIS		 7433 }
7434 else {
a0714e2c 7435 kSVOP->op_sv = NULL;
1c846c1f 7436 }
f5d5a27c 7437 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 7438#ifdef PERL_MAD
7439 op_getmad(o,cmop,'O');
7440#else
f5d5a27c 7441 op_free(o);
eb8433b7 7442#endif
f5d5a27c
CS		 7443 return cmop;
7444 }
7445 }
7446 return o;
7447}
7448
7449OP *
cea2e8a9 7450Perl_ck_null(pTHX_ OP *o)
79072805 7451{
7918f24d 7452 PERL_ARGS_ASSERT_CK_NULL;
96a5add6 7453 PERL_UNUSED_CONTEXT;
11343788 7454 return o;
79072805
LW		 7455}
7456
7457OP *
16fe6d59
GS		 7458Perl_ck_open(pTHX_ OP *o)
7459{
97aff369 7460 dVAR;
551405c4 7461 HV * const table = GvHV(PL_hintgv);
7918f24d
NC		 7462
7463 PERL_ARGS_ASSERT_CK_OPEN;
7464
16fe6d59 7465 if (table) {
a4fc7abc 7466 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 7467 if (svp && *svp) {
a79b25b7
VP		 7468 STRLEN len = 0;
7469 const char *d = SvPV_const(*svp, len);
7470 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 7471 if (mode & O_BINARY)
7472 o->op_private |= OPpOPEN_IN_RAW;
7473 else if (mode & O_TEXT)
7474 o->op_private |= OPpOPEN_IN_CRLF;
7475 }
7476
a4fc7abc 7477 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 7478 if (svp && *svp) {
a79b25b7
VP		 7479 STRLEN len = 0;
7480 const char *d = SvPV_const(*svp, len);
7481 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 7482 if (mode & O_BINARY)
7483 o->op_private |= OPpOPEN_OUT_RAW;
7484 else if (mode & O_TEXT)
7485 o->op_private |= OPpOPEN_OUT_CRLF;
7486 }
7487 }
8d7403e6
RGS		 7488 if (o->op_type == OP_BACKTICK) {
7489 if (!(o->op_flags & OPf_KIDS)) {
e4b7ebf3
RGS		 7490 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7491#ifdef PERL_MAD
7492 op_getmad(o,newop,'O');
7493#else
8d7403e6 7494 op_free(o);
e4b7ebf3
RGS		 7495#endif
7496 return newop;
8d7403e6 7497 }
16fe6d59 7498 return o;
8d7403e6 7499 }
3b82e551
JH		 7500 {
7501 /* In case of three-arg dup open remove strictness
7502 * from the last arg if it is a bareword. */
551405c4
AL		 7503 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7504 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 7505 OP *oa;
b15aece3 7506 const char *mode;
3b82e551
JH		 7507
7508 if ((last->op_type == OP_CONST) && /* The bareword. */
7509 (last->op_private & OPpCONST_BARE) &&
7510 (last->op_private & OPpCONST_STRICT) &&
7511 (oa = first->op_sibling) && /* The fh. */
7512 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 7513 (oa->op_type == OP_CONST) &&
3b82e551 7514 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 7515 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 7516 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7517 (last == oa->op_sibling)) /* The bareword. */
7518 last->op_private &= ~OPpCONST_STRICT;
7519 }
16fe6d59
GS		 7520 return ck_fun(o);
7521}
7522
7523OP *
cea2e8a9 7524Perl_ck_repeat(pTHX_ OP *o)
79072805 7525{
7918f24d
NC		 7526 PERL_ARGS_ASSERT_CK_REPEAT;
7527
11343788
MB		 7528 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7529 o->op_private |= OPpREPEAT_DOLIST;
7530 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 7531 }
7532 else
11343788
MB		 7533 scalar(o);
7534 return o;
79072805
LW		 7535}
7536
7537OP *
cea2e8a9 7538Perl_ck_require(pTHX_ OP *o)
8990e307 7539{
97aff369 7540 dVAR;
a0714e2c 7541 GV* gv = NULL;
ec4ab249 7542
7918f24d
NC		 7543 PERL_ARGS_ASSERT_CK_REQUIRE;
7544
11343788 7545 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 7546 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 7547
7548 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 7549 SV * const sv = kid->op_sv;
5c144d81 7550 U32 was_readonly = SvREADONLY(sv);
8990e307 7551 char *s;
cfff9797
NC		 7552 STRLEN len;
7553 const char *end;
5c144d81
NC		 7554
7555 if (was_readonly) {
7556 if (SvFAKE(sv)) {
7557 sv_force_normal_flags(sv, 0);
7558 assert(!SvREADONLY(sv));
7559 was_readonly = 0;
7560 } else {
7561 SvREADONLY_off(sv);
7562 }
7563 }
7564
cfff9797
NC		 7565 s = SvPVX(sv);
7566 len = SvCUR(sv);
7567 end = s + len;
7568 for (; s < end; s++) {
a0d0e21e
LW		 7569 if (*s == ':' && s[1] == ':') {
7570 *s = '/';
5c6b2528 7571 Move(s+2, s+1, end - s - 1, char);
cfff9797 7572 --end;
a0d0e21e 7573 }
8990e307 7574 }
cfff9797 7575 SvEND_set(sv, end);
396482e1 7576 sv_catpvs(sv, ".pm");
5c144d81 7577 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 7578 }
7579 }
ec4ab249 7580
a72a1c8b
RGS		 7581 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7582 /* handle override, if any */
fafc274c 7583 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 7584 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 7585 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 7586 gv = gvp ? *gvp : NULL;
d6a985f2 7587 }
a72a1c8b 7588 }
ec4ab249 7589
b9f751c0 7590 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 7591 OP * const kid = cUNOPo->op_first;
f11453cb
NC		 7592 OP * newop;
7593
ec4ab249 7594 cUNOPo->op_first = 0;
f11453cb 7595#ifndef PERL_MAD
ec4ab249 7596 op_free(o);
eb8433b7 7597#endif
f11453cb
NC		 7598 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7599 append_elem(OP_LIST, kid,
7600 scalar(newUNOP(OP_RV2CV, 0,
7601 newGVOP(OP_GV, 0,
7602 gv))))));
7603 op_getmad(o,newop,'O');
eb8433b7 7604 return newop;
ec4ab249
GA		 7605 }
7606
11343788 7607 return ck_fun(o);
8990e307
LW		 7608}
7609
78f9721b
SM		 7610OP *
7611Perl_ck_return(pTHX_ OP *o)
7612{
97aff369 7613 dVAR;
e91684bf 7614 OP *kid;
7918f24d
NC		 7615
7616 PERL_ARGS_ASSERT_CK_RETURN;
7617
e91684bf 7618 kid = cLISTOPo->op_first->op_sibling;
78f9721b 7619 if (CvLVALUE(PL_compcv)) {
e91684bf 7620 for (; kid; kid = kid->op_sibling)
78f9721b 7621 mod(kid, OP_LEAVESUBLV);
e91684bf
VP		 7622 } else {
7623 for (; kid; kid = kid->op_sibling)
7624 if ((kid->op_type == OP_NULL)
1c8a4223 7625 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
e91684bf 7626 /* This is a do block */
1c8a4223
VP		 7627 OP *op = kUNOP->op_first;
7628 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7629 op = cUNOPx(op)->op_first;
7630 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7631 /* Force the use of the caller's context */
7632 op->op_flags |= OPf_SPECIAL;
7633 }
e91684bf 7634 }
78f9721b 7635 }
e91684bf 7636
78f9721b
SM		 7637 return o;
7638}
7639
79072805 7640OP *
cea2e8a9 7641Perl_ck_select(pTHX_ OP *o)
79072805 7642{
27da23d5 7643 dVAR;
c07a80fd 7644 OP* kid;
7918f24d
NC		 7645
7646 PERL_ARGS_ASSERT_CK_SELECT;
7647
11343788
MB		 7648 if (o->op_flags & OPf_KIDS) {
7649 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 7650 if (kid && kid->op_sibling) {
11343788 7651 o->op_type = OP_SSELECT;
22c35a8c 7652 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 7653 o = ck_fun(o);
7654 return fold_constants(o);
79072805
LW		 7655 }
7656 }
11343788
MB		 7657 o = ck_fun(o);
7658 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 7659 if (kid && kid->op_type == OP_RV2GV)
7660 kid->op_private &= ~HINT_STRICT_REFS;
11343788 7661 return o;
79072805
LW		 7662}
7663
7664OP *
cea2e8a9 7665Perl_ck_shift(pTHX_ OP *o)
79072805 7666{
97aff369 7667 dVAR;
6867be6d 7668 const I32 type = o->op_type;
79072805 7669
7918f24d
NC		 7670 PERL_ARGS_ASSERT_CK_SHIFT;
7671
11343788 7672 if (!(o->op_flags & OPf_KIDS)) {
821005df 7673 OP *argop = newUNOP(OP_RV2AV, 0,
8fde6460 7674 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
eb8433b7 7675#ifdef PERL_MAD
821005df 7676 OP * const oldo = o;
eb8433b7
NC		 7677 o = newUNOP(type, 0, scalar(argop));
7678 op_getmad(oldo,o,'O');
7679 return o;
7680#else
821005df 7681 op_free(o);
6d4ff0d2 7682 return newUNOP(type, 0, scalar(argop));
eb8433b7 7683#endif
79072805 7684 }
11343788 7685 return scalar(modkids(ck_fun(o), type));
79072805
LW		 7686}
7687
7688OP *
cea2e8a9 7689Perl_ck_sort(pTHX_ OP *o)
79072805 7690{
97aff369 7691 dVAR;
8e3f9bdf 7692 OP *firstkid;
bbce6d69 7693
7918f24d
NC		 7694 PERL_ARGS_ASSERT_CK_SORT;
7695
1496a290 7696 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
a4fc7abc 7697 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 7698 if (hinthv) {
a4fc7abc 7699 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 7700 if (svp) {
a4fc7abc 7701 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 7702 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7703 o->op_private |= OPpSORT_QSORT;
7704 if ((sorthints & HINT_SORT_STABLE) != 0)
7705 o->op_private |= OPpSORT_STABLE;
7706 }
7707 }
7708 }
7709
9ea6e965 7710 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 7711 simplify_sort(o);
8e3f9bdf
GS		 7712 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7713 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 7714 OP *k = NULL;
8e3f9bdf 7715 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 7716
463ee0b2 7717 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 7718 linklist(kid);
463ee0b2
LW		 7719 if (kid->op_type == OP_SCOPE) {
7720 k = kid->op_next;
7721 kid->op_next = 0;
79072805 7722 }
463ee0b2 7723 else if (kid->op_type == OP_LEAVE) {
11343788 7724 if (o->op_type == OP_SORT) {
93c66552 7725 op_null(kid); /* wipe out leave */
748a9306 7726 kid->op_next = kid;
463ee0b2 7727
748a9306
LW		 7728 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7729 if (k->op_next == kid)
7730 k->op_next = 0;
71a29c3c
GS		 7731 /* don't descend into loops */
7732 else if (k->op_type == OP_ENTERLOOP
7733 || k->op_type == OP_ENTERITER)
7734 {
7735 k = cLOOPx(k)->op_lastop;
7736 }
748a9306 7737 }
463ee0b2 7738 }
748a9306
LW		 7739 else
7740 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 7741 k = kLISTOP->op_first;
463ee0b2 7742 }
a2efc822 7743 CALL_PEEP(k);
a0d0e21e 7744
8e3f9bdf
GS		 7745 kid = firstkid;
7746 if (o->op_type == OP_SORT) {
7747 /* provide scalar context for comparison function/block */
7748 kid = scalar(kid);
a0d0e21e 7749 kid->op_next = kid;
8e3f9bdf 7750 }
a0d0e21e
LW		 7751 else
7752 kid->op_next = k;
11343788 7753 o->op_flags |= OPf_SPECIAL;
79072805 7754 }
c6e96bcb 7755 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 7756 op_null(firstkid);
8e3f9bdf
GS		 7757
7758 firstkid = firstkid->op_sibling;
79072805 7759 }
bbce6d69 7760
8e3f9bdf
GS		 7761 /* provide list context for arguments */
7762 if (o->op_type == OP_SORT)
7763 list(firstkid);
7764
11343788 7765 return o;
79072805 7766}
bda4119b
GS		 7767
7768STATIC void
cea2e8a9 7769S_simplify_sort(pTHX_ OP *o)
9c007264 7770{
97aff369 7771 dVAR;
9c007264
JH		 7772 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7773 OP *k;
eb209983 7774 int descending;
350de78d 7775 GV *gv;
770526c1 7776 const char *gvname;
7918f24d
NC		 7777
7778 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7779
9c007264
JH		 7780 if (!(o->op_flags & OPf_STACKED))
7781 return;
fafc274c
NC		 7782 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7783 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 7784 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 7785 if (kid->op_type != OP_SCOPE)
7786 return;
7787 kid = kLISTOP->op_last; /* get past scope */
7788 switch(kid->op_type) {
7789 case OP_NCMP:
7790 case OP_I_NCMP:
7791 case OP_SCMP:
7792 break;
7793 default:
7794 return;
7795 }
7796 k = kid; /* remember this node*/
7797 if (kBINOP->op_first->op_type != OP_RV2SV)
7798 return;
7799 kid = kBINOP->op_first; /* get past cmp */
7800 if (kUNOP->op_first->op_type != OP_GV)
7801 return;
7802 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7803 gv = kGVOP_gv;
350de78d 7804 if (GvSTASH(gv) != PL_curstash)
9c007264 7805 return;
770526c1
NC		 7806 gvname = GvNAME(gv);
7807 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 7808 descending = 0;
770526c1 7809 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 7810 descending = 1;
9c007264
JH		 7811 else
7812 return;
eb209983 7813
9c007264
JH		 7814 kid = k; /* back to cmp */
7815 if (kBINOP->op_last->op_type != OP_RV2SV)
7816 return;
7817 kid = kBINOP->op_last; /* down to 2nd arg */
7818 if (kUNOP->op_first->op_type != OP_GV)
7819 return;
7820 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7821 gv = kGVOP_gv;
770526c1
NC		 7822 if (GvSTASH(gv) != PL_curstash)
7823 return;
7824 gvname = GvNAME(gv);
7825 if ( descending
7826 ? !(*gvname == 'a' && gvname[1] == '\0')
7827 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 7828 return;
7829 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 7830 if (descending)
7831 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 7832 if (k->op_type == OP_NCMP)
7833 o->op_private |= OPpSORT_NUMERIC;
7834 if (k->op_type == OP_I_NCMP)
7835 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 7836 kid = cLISTOPo->op_first->op_sibling;
7837 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 7838#ifdef PERL_MAD
7839 op_getmad(kid,o,'S'); /* then delete it */
7840#else
e507f050 7841 op_free(kid); /* then delete it */
eb8433b7 7842#endif
9c007264 7843}
79072805
LW		 7844
7845OP *
cea2e8a9 7846Perl_ck_split(pTHX_ OP *o)
79072805 7847{
27da23d5 7848 dVAR;
79072805 7849 register OP *kid;
aeea060c 7850
7918f24d
NC		 7851 PERL_ARGS_ASSERT_CK_SPLIT;
7852
11343788
MB		 7853 if (o->op_flags & OPf_STACKED)
7854 return no_fh_allowed(o);
79072805 7855
11343788 7856 kid = cLISTOPo->op_first;
8990e307 7857 if (kid->op_type != OP_NULL)
cea2e8a9 7858 Perl_croak(aTHX_ "panic: ck_split");
8990e307 7859 kid = kid->op_sibling;
11343788
MB		 7860 op_free(cLISTOPo->op_first);
7861 cLISTOPo->op_first = kid;
85e6fe83 7862 if (!kid) {
396482e1 7863 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 7864 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 7865 }
79072805 7866
de4bf5b3 7867 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 7868 OP * const sibl = kid->op_sibling;
463ee0b2 7869 kid->op_sibling = 0;
131b3ad0 7870 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 7871 if (cLISTOPo->op_first == cLISTOPo->op_last)
7872 cLISTOPo->op_last = kid;
7873 cLISTOPo->op_first = kid;
79072805
LW		 7874 kid->op_sibling = sibl;
7875 }
7876
7877 kid->op_type = OP_PUSHRE;
22c35a8c 7878 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 7879 scalar(kid);
a2a5de95
NC		 7880 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7881 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7882 "Use of /g modifier is meaningless in split");
f34840d8 7883 }
79072805
LW		 7884
7885 if (!kid->op_sibling)
54b9620d 7886 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 7887
7888 kid = kid->op_sibling;
7889 scalar(kid);
7890
7891 if (!kid->op_sibling)
11343788 7892 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
ce3e5c45 7893 assert(kid->op_sibling);
79072805
LW		 7894
7895 kid = kid->op_sibling;
7896 scalar(kid);
7897
7898 if (kid->op_sibling)
53e06cf0 7899 return too_many_arguments(o,OP_DESC(o));
79072805 7900
11343788 7901 return o;
79072805
LW		 7902}
7903
7904OP *
1c846c1f 7905Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 7906{
551405c4 7907 const OP * const kid = cLISTOPo->op_first->op_sibling;
7918f24d
NC		 7908
7909 PERL_ARGS_ASSERT_CK_JOIN;
7910
041457d9
DM		 7911 if (kid && kid->op_type == OP_MATCH) {
7912 if (ckWARN(WARN_SYNTAX)) {
6867be6d 7913 const REGEXP *re = PM_GETRE(kPMOP);
d2c6dc5e 7914 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
220fc49f 7915 const STRLEN len = re ? RX_PRELEN(re) : 6;
9014280d 7916 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
bcdf7404 7917 "/%.*s/ should probably be written as \"%.*s\"",
d83b45b8 7918 (int)len, pmstr, (int)len, pmstr);
eb6e2d6f
GS		 7919 }
7920 }
7921 return ck_fun(o);
7922}
7923
7924OP *
cea2e8a9 7925Perl_ck_subr(pTHX_ OP *o)
79072805 7926{
97aff369 7927 dVAR;
11343788
MB		 7928 OP *prev = ((cUNOPo->op_first->op_sibling)
7929 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7930 OP *o2 = prev->op_sibling;
4633a7c4 7931 OP *cvop;
a0751766 7932 const char *proto = NULL;
cbf82dd0 7933 const char *proto_end = NULL;
c445ea15
AL		 7934 CV *cv = NULL;
7935 GV *namegv = NULL;
4633a7c4
LW		 7936 int optional = 0;
7937 I32 arg = 0;
5b794e05 7938 I32 contextclass = 0;
d3fcec1f 7939 const char *e = NULL;
0723351e 7940 bool delete_op = 0;
4633a7c4 7941
7918f24d
NC		 7942 PERL_ARGS_ASSERT_CK_SUBR;
7943
d3011074 7944 o->op_private |= OPpENTERSUB_HASTARG;
11343788 7945 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 7946 if (cvop->op_type == OP_RV2CV) {
7947 SVOP* tmpop;
11343788 7948 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 7949 op_null(cvop); /* disable rv2cv */
4633a7c4 7950 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 7951 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 7952 GV *gv = cGVOPx_gv(tmpop);
350de78d 7953 cv = GvCVu(gv);
76cd736e
GS		 7954 if (!cv)
7955 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 7956 else {
7957 if (SvPOK(cv)) {
cbf82dd0 7958 STRLEN len;
06492da6 7959 namegv = CvANON(cv) ? gv : CvGV(cv);
ad64d0ec 7960 proto = SvPV(MUTABLE_SV(cv), len);
cbf82dd0 7961 proto_end = proto + len;
06492da6 7962 }
46fc3d4c 7963 }
4633a7c4
LW		 7964 }
7965 }
f5d5a27c 7966 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 7967 if (o2->op_type == OP_CONST)
7968 o2->op_private &= ~OPpCONST_STRICT;
58a40671 7969 else if (o2->op_type == OP_LIST) {
5f66b61c
AL		 7970 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7971 if (sib && sib->op_type == OP_CONST)
7972 sib->op_private &= ~OPpCONST_STRICT;
58a40671 7973 }
7a52d87a 7974 }
3280af22
NIS		 7975 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7976 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 7977 o->op_private |= OPpENTERSUB_DB;
7978 while (o2 != cvop) {
eb8433b7 7979 OP* o3;
9fc012f4
GG		 7980 if (PL_madskills && o2->op_type == OP_STUB) {
7981 o2 = o2->op_sibling;
7982 continue;
7983 }
eb8433b7
NC		 7984 if (PL_madskills && o2->op_type == OP_NULL)
7985 o3 = ((UNOP*)o2)->op_first;
7986 else
7987 o3 = o2;
4633a7c4 7988 if (proto) {
cbf82dd0 7989 if (proto >= proto_end)
5dc0d613 7990 return too_many_arguments(o, gv_ename(namegv));
cbf82dd0
NC		 7991
7992 switch (*proto) {
4633a7c4
LW		 7993 case ';':
7994 optional = 1;
7995 proto++;
7996 continue;
b13fd70a 7997 case '_':
f00d1d61 7998 /* _ must be at the end */
cb40c25d 7999 if (proto[1] && proto[1] != ';')
f00d1d61 8000 goto oops;
4633a7c4
LW		 8001 case '$':
8002 proto++;
8003 arg++;
11343788 8004 scalar(o2);
4633a7c4
LW		 8005 break;
8006 case '%':
8007 case '@':
11343788 8008 list(o2);
4633a7c4
LW		 8009 arg++;
8010 break;
8011 case '&':
8012 proto++;
8013 arg++;
eb8433b7 8014 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
75fc29ea 8015 bad_type(arg,
666ea192
JH		 8016 arg == 1 ? "block or sub {}" : "sub {}",
8017 gv_ename(namegv), o3);
4633a7c4
LW		 8018 break;
8019 case '*':
2ba6ecf4 8020 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 8021 proto++;
8022 arg++;
eb8433b7 8023 if (o3->op_type == OP_RV2GV)
2ba6ecf4 8024 goto wrapref; /* autoconvert GLOB -> GLOBref */
eb8433b7
NC		 8025 else if (o3->op_type == OP_CONST)
8026 o3->op_private &= ~OPpCONST_STRICT;
8027 else if (o3->op_type == OP_ENTERSUB) {
9675f7ac 8028 /* accidental subroutine, revert to bareword */
eb8433b7 8029 OP *gvop = ((UNOP*)o3)->op_first;
9675f7ac
GS		 8030 if (gvop && gvop->op_type == OP_NULL) {
8031 gvop = ((UNOP*)gvop)->op_first;
8032 if (gvop) {
8033 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8034 ;
8035 if (gvop &&
8036 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8037 (gvop = ((UNOP*)gvop)->op_first) &&
8038 gvop->op_type == OP_GV)
8039 {
551405c4
AL		 8040 GV * const gv = cGVOPx_gv(gvop);
8041 OP * const sibling = o2->op_sibling;
396482e1 8042 SV * const n = newSVpvs("");
eb8433b7 8043#ifdef PERL_MAD
1d866c12 8044 OP * const oldo2 = o2;
eb8433b7 8045#else
9675f7ac 8046 op_free(o2);
eb8433b7 8047#endif
2a797ae2 8048 gv_fullname4(n, gv, "", FALSE);
2692f720 8049 o2 = newSVOP(OP_CONST, 0, n);
eb8433b7 8050 op_getmad(oldo2,o2,'O');
9675f7ac
GS		 8051 prev->op_sibling = o2;
8052 o2->op_sibling = sibling;
8053 }
8054 }
8055 }
8056 }
2ba6ecf4
GS		 8057 scalar(o2);
8058 break;
5b794e05
JH		 8059 case '[': case ']':
8060 goto oops;
8061 break;
4633a7c4
LW		 8062 case '\\':
8063 proto++;
8064 arg++;
5b794e05 8065 again:
4633a7c4 8066 switch (*proto++) {
5b794e05
JH		 8067 case '[':
8068 if (contextclass++ == 0) {
841d93c8 8069 e = strchr(proto, ']');
5b794e05
JH		 8070 if (!e || e == proto)
8071 goto oops;
8072 }
8073 else
8074 goto oops;
8075 goto again;
8076 break;
8077 case ']':
466bafcd 8078 if (contextclass) {
a0751766
NC		 8079 const char *p = proto;
8080 const char *const end = proto;
466bafcd 8081 contextclass = 0;
47127b64 8082 while (*--p != '[') {}
a0751766
NC		 8083 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8084 (int)(end - p), p),
8085 gv_ename(namegv), o3);
466bafcd 8086 } else
5b794e05
JH		 8087 goto oops;
8088 break;
4633a7c4 8089 case '*':
eb8433b7 8090 if (o3->op_type == OP_RV2GV)
5b794e05
JH		 8091 goto wrapref;
8092 if (!contextclass)
eb8433b7 8093 bad_type(arg, "symbol", gv_ename(namegv), o3);
5b794e05 8094 break;
4633a7c4 8095 case '&':
eb8433b7 8096 if (o3->op_type == OP_ENTERSUB)
5b794e05
JH		 8097 goto wrapref;
8098 if (!contextclass)
eb8433b7
NC		 8099 bad_type(arg, "subroutine entry", gv_ename(namegv),
8100 o3);
5b794e05 8101 break;
4633a7c4 8102 case '$':
eb8433b7
NC		 8103 if (o3->op_type == OP_RV2SV ||
8104 o3->op_type == OP_PADSV ||
8105 o3->op_type == OP_HELEM ||
5b9081af 8106 o3->op_type == OP_AELEM)
5b794e05
JH		 8107 goto wrapref;
8108 if (!contextclass)
eb8433b7 8109 bad_type(arg, "scalar", gv_ename(namegv), o3);
5b794e05 8110 break;
4633a7c4 8111 case '@':
eb8433b7
NC		 8112 if (o3->op_type == OP_RV2AV ||
8113 o3->op_type == OP_PADAV)
5b794e05
JH		 8114 goto wrapref;
8115 if (!contextclass)
eb8433b7 8116 bad_type(arg, "array", gv_ename(namegv), o3);
5b794e05 8117 break;
4633a7c4 8118 case '%':
eb8433b7
NC		 8119 if (o3->op_type == OP_RV2HV ||
8120 o3->op_type == OP_PADHV)
5b794e05
JH		 8121 goto wrapref;
8122 if (!contextclass)
eb8433b7 8123 bad_type(arg, "hash", gv_ename(namegv), o3);
5b794e05
JH		 8124 break;
8125 wrapref:
4633a7c4 8126 {
551405c4
AL		 8127 OP* const kid = o2;
8128 OP* const sib = kid->op_sibling;
4633a7c4 8129 kid->op_sibling = 0;
6fa846a0
GS		 8130 o2 = newUNOP(OP_REFGEN, 0, kid);
8131 o2->op_sibling = sib;
e858de61 8132 prev->op_sibling = o2;
4633a7c4 8133 }
841d93c8 8134 if (contextclass && e) {
5b794e05
JH		 8135 proto = e + 1;
8136 contextclass = 0;
8137 }
4633a7c4
LW		 8138 break;
8139 default: goto oops;
8140 }
5b794e05
JH		 8141 if (contextclass)
8142 goto again;
4633a7c4 8143 break;
b1cb66bf 8144 case ' ':
8145 proto++;
8146 continue;
4633a7c4
LW		 8147 default:
8148 oops:
35c1215d 8149 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
be2597df 8150 gv_ename(namegv), SVfARG(cv));
4633a7c4
LW		 8151 }
8152 }
8153 else
11343788
MB		 8154 list(o2);
8155 mod(o2, OP_ENTERSUB);
8156 prev = o2;
8157 o2 = o2->op_sibling;
551405c4 8158 } /* while */
236b555a
RGS		 8159 if (o2 == cvop && proto && *proto == '_') {
8160 /* generate an access to $_ */
8161 o2 = newDEFSVOP();
8162 o2->op_sibling = prev->op_sibling;
8163 prev->op_sibling = o2; /* instead of cvop */
8164 }
cbf82dd0 8165 if (proto && !optional && proto_end > proto &&
236b555a 8166 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
5dc0d613 8167 return too_few_arguments(o, gv_ename(namegv));
0723351e 8168 if(delete_op) {
eb8433b7 8169#ifdef PERL_MAD
1d866c12 8170 OP * const oldo = o;
eb8433b7 8171#else
06492da6 8172 op_free(o);
eb8433b7 8173#endif
06492da6 8174 o=newSVOP(OP_CONST, 0, newSViv(0));
eb8433b7 8175 op_getmad(oldo,o,'O');
06492da6 8176 }
11343788 8177 return o;
79072805
LW		 8178}
8179
8180OP *
cea2e8a9 8181Perl_ck_svconst(pTHX_ OP *o)
8990e307 8182{
7918f24d 8183 PERL_ARGS_ASSERT_CK_SVCONST;
96a5add6 8184 PERL_UNUSED_CONTEXT;
11343788
MB		 8185 SvREADONLY_on(cSVOPo->op_sv);
8186 return o;
8990e307
LW		 8187}
8188
8189OP *
d4ac975e
GA		 8190Perl_ck_chdir(pTHX_ OP *o)
8191{
8192 if (o->op_flags & OPf_KIDS) {
1496a290 8193 SVOP * const kid = (SVOP*)cUNOPo->op_first;
d4ac975e
GA		 8194
8195 if (kid && kid->op_type == OP_CONST &&
8196 (kid->op_private & OPpCONST_BARE))
8197 {
8198 o->op_flags |= OPf_SPECIAL;
8199 kid->op_private &= ~OPpCONST_STRICT;
8200 }
8201 }
8202 return ck_fun(o);
8203}
8204
8205OP *
cea2e8a9 8206Perl_ck_trunc(pTHX_ OP *o)
79072805 8207{
7918f24d
NC		 8208 PERL_ARGS_ASSERT_CK_TRUNC;
8209
11343788
MB		 8210 if (o->op_flags & OPf_KIDS) {
8211 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 8212
a0d0e21e
LW		 8213 if (kid->op_type == OP_NULL)
8214 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 8215 if (kid && kid->op_type == OP_CONST &&
8216 (kid->op_private & OPpCONST_BARE))
8217 {
11343788 8218 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 8219 kid->op_private &= ~OPpCONST_STRICT;
8220 }
79072805 8221 }
11343788 8222 return ck_fun(o);
79072805
LW		 8223}
8224
35fba0d9 8225OP *
bab9c0ac
RGS		 8226Perl_ck_unpack(pTHX_ OP *o)
8227{
8228 OP *kid = cLISTOPo->op_first;
7918f24d
NC		 8229
8230 PERL_ARGS_ASSERT_CK_UNPACK;
8231
bab9c0ac
RGS		 8232 if (kid->op_sibling) {
8233 kid = kid->op_sibling;
8234 if (!kid->op_sibling)
8235 kid->op_sibling = newDEFSVOP();
8236 }
8237 return ck_fun(o);
8238}
8239
8240OP *
35fba0d9
RG		 8241Perl_ck_substr(pTHX_ OP *o)
8242{
7918f24d
NC		 8243 PERL_ARGS_ASSERT_CK_SUBSTR;
8244
35fba0d9 8245 o = ck_fun(o);
1d866c12 8246 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 8247 OP *kid = cLISTOPo->op_first;
8248
8249 if (kid->op_type == OP_NULL)
8250 kid = kid->op_sibling;
8251 if (kid)
8252 kid->op_flags |= OPf_MOD;
8253
8254 }
8255 return o;
8256}
8257
878d132a
NC		 8258OP *
8259Perl_ck_each(pTHX_ OP *o)
8260{
d75c0fe7 8261 dVAR;
a916b302 8262 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
878d132a 8263
7918f24d
NC		 8264 PERL_ARGS_ASSERT_CK_EACH;
8265
a916b302
RGS		 8266 if (kid) {
8267 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8268 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8269 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8270 o->op_type = new_type;
8271 o->op_ppaddr = PL_ppaddr[new_type];
8272 }
8273 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8274 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8275 )) {
8276 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8277 return o;
8278 }
878d132a
NC		 8279 }
8280 return ck_fun(o);
8281}
8282
867fa1e2
YO		 8283/* caller is supposed to assign the return to the
8284 container of the rep_op var */
8285OP *
8286S_opt_scalarhv(pTHX_ OP *rep_op) {
8287 UNOP *unop;
8288
8289 PERL_ARGS_ASSERT_OPT_SCALARHV;
8290
8291 NewOp(1101, unop, 1, UNOP);
8292 unop->op_type = (OPCODE)OP_BOOLKEYS;
8293 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8294 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8295 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8296 unop->op_first = rep_op;
8297 unop->op_next = rep_op->op_next;
8298 rep_op->op_next = (OP*)unop;
8299 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8300 unop->op_sibling = rep_op->op_sibling;
8301 rep_op->op_sibling = NULL;
8302 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8303 if (rep_op->op_type == OP_PADHV) {
8304 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8305 rep_op->op_flags |= OPf_WANT_LIST;
8306 }
8307 return (OP*)unop;
8308}
8309
61b743bb
DM		 8310/* A peephole optimizer. We visit the ops in the order they're to execute.
8311 * See the comments at the top of this file for more details about when
8312 * peep() is called */
463ee0b2 8313
79072805 8314void
864dbfa3 8315Perl_peep(pTHX_ register OP *o)
79072805 8316{
27da23d5 8317 dVAR;
c445ea15 8318 register OP* oldop = NULL;
2d8e6c8d 8319
2814eb74 8320 if (!o || o->op_opt)
79072805 8321 return;
a0d0e21e 8322 ENTER;
462e5cf6 8323 SAVEOP();
7766f137 8324 SAVEVPTR(PL_curcop);
a0d0e21e 8325 for (; o; o = o->op_next) {
2814eb74 8326 if (o->op_opt)
a0d0e21e 8327 break;
6d7dd4a5
NC		 8328 /* By default, this op has now been optimised. A couple of cases below
8329 clear this again. */
8330 o->op_opt = 1;
533c011a 8331 PL_op = o;
a0d0e21e
LW		 8332 switch (o->op_type) {
8333 case OP_NEXTSTATE:
8334 case OP_DBSTATE:
3280af22 8335 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e
LW		 8336 break;
8337
a0d0e21e 8338 case OP_CONST:
7a52d87a
GS		 8339 if (cSVOPo->op_private & OPpCONST_STRICT)
8340 no_bareword_allowed(o);
7766f137 8341#ifdef USE_ITHREADS
996c9baa 8342 case OP_HINTSEVAL:
3848b962 8343 case OP_METHOD_NAMED:
7766f137
GS		 8344 /* Relocate sv to the pad for thread safety.
8345 * Despite being a "constant", the SV is written to,
8346 * for reference counts, sv_upgrade() etc. */
8347 if (cSVOP->op_sv) {
6867be6d 8348 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
996c9baa 8349 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 8350 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 8351 * some pad, so make a copy. */
dd2155a4
DM		 8352 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8353 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 8354 SvREFCNT_dec(cSVOPo->op_sv);
8355 }
996c9baa 8356 else if (o->op_type != OP_METHOD_NAMED
052ca17e
NC		 8357 && cSVOPo->op_sv == &PL_sv_undef) {
8358 /* PL_sv_undef is hack - it's unsafe to store it in the
8359 AV that is the pad, because av_fetch treats values of
8360 PL_sv_undef as a "free" AV entry and will merrily
8361 replace them with a new SV, causing pad_alloc to think
8362 that this pad slot is free. (When, clearly, it is not)
8363 */
8364 SvOK_off(PAD_SVl(ix));
8365 SvPADTMP_on(PAD_SVl(ix));
8366 SvREADONLY_on(PAD_SVl(ix));
8367 }
6a7129a1 8368 else {
dd2155a4 8369 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 8370 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 8371 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 8372 /* XXX I don't know how this isn't readonly already. */
dd2155a4 8373 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 8374 }
a0714e2c 8375 cSVOPo->op_sv = NULL;
7766f137
GS		 8376 o->op_targ = ix;
8377 }
8378#endif
07447971
GS		 8379 break;
8380
df91b2c5
AE		 8381 case OP_CONCAT:
8382 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8383 if (o->op_next->op_private & OPpTARGET_MY) {
8384 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 8385 break; /* ignore_optimization */
df91b2c5
AE		 8386 else {
8387 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8388 o->op_targ = o->op_next->op_targ;
8389 o->op_next->op_targ = 0;
8390 o->op_private |= OPpTARGET_MY;
8391 }
8392 }
8393 op_null(o->op_next);
8394 }
df91b2c5 8395 break;
6d7dd4a5
NC		 8396 case OP_STUB:
8397 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8398 break; /* Scalar stub must produce undef. List stub is noop */
8399 }
8400 goto nothin;
79072805 8401 case OP_NULL:
acb36ea4 8402 if (o->op_targ == OP_NEXTSTATE
5edb5b2a 8403 || o->op_targ == OP_DBSTATE)
acb36ea4 8404 {
3280af22 8405 PL_curcop = ((COP*)o);
acb36ea4 8406 }
dad75012
AMS		 8407 /* XXX: We avoid setting op_seq here to prevent later calls
8408 to peep() from mistakenly concluding that optimisation
8409 has already occurred. This doesn't fix the real problem,
8410 though (See 20010220.007). AMS 20010719 */
2814eb74 8411 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 8412 o->op_opt = 0;
f46f2f82 8413 /* FALL THROUGH */
79072805 8414 case OP_SCALAR:
93a17b20 8415 case OP_LINESEQ:
463ee0b2 8416 case OP_SCOPE:
6d7dd4a5 8417 nothin:
a0d0e21e
LW		 8418 if (oldop && o->op_next) {
8419 oldop->op_next = o->op_next;
6d7dd4a5 8420 o->op_opt = 0;
79072805
LW		 8421 continue;
8422 }
79072805
LW		 8423 break;
8424
6a077020 8425 case OP_PADAV:
79072805 8426 case OP_GV:
6a077020 8427 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 8428 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 8429 o->op_next : o->op_next->op_next;
a0d0e21e 8430 IV i;
f9dc862f 8431 if (pop && pop->op_type == OP_CONST &&
af5acbb4 8432 ((PL_op = pop->op_next)) &&
8990e307 8433 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 8434 !(pop->op_next->op_private &
78f9721b 8435 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
fc15ae8f 8436 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
a0d0e21e 8437 <= 255 &&
8990e307
LW		 8438 i >= 0)
8439 {
350de78d 8440 GV *gv;
af5acbb4
DM		 8441 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8442 no_bareword_allowed(pop);
6a077020
DM		 8443 if (o->op_type == OP_GV)
8444 op_null(o->op_next);
93c66552
DM		 8445 op_null(pop->op_next);
8446 op_null(pop);
a0d0e21e
LW		 8447 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8448 o->op_next = pop->op_next->op_next;
22c35a8c 8449 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 8450 o->op_private = (U8)i;
6a077020
DM		 8451 if (o->op_type == OP_GV) {
8452 gv = cGVOPo_gv;
8453 GvAVn(gv);
8454 }
8455 else
8456 o->op_flags |= OPf_SPECIAL;
8457 o->op_type = OP_AELEMFAST;
8458 }
6a077020
DM		 8459 break;
8460 }
8461
8462 if (o->op_next->op_type == OP_RV2SV) {
8463 if (!(o->op_next->op_private & OPpDEREF)) {
8464 op_null(o->op_next);
8465 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8466 | OPpOUR_INTRO);
8467 o->op_next = o->op_next->op_next;
8468 o->op_type = OP_GVSV;
8469 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 8470 }
79072805 8471 }
e476b1b5 8472 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
551405c4 8473 GV * const gv = cGVOPo_gv;
b15aece3 8474 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 8475 /* XXX could check prototype here instead of just carping */
551405c4 8476 SV * const sv = sv_newmortal();
bd61b366 8477 gv_efullname3(sv, gv, NULL);
9014280d 8478 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d 8479 "%"SVf"() called too early to check prototype",
be2597df 8480 SVfARG(sv));
76cd736e
GS		 8481 }
8482 }
89de2904
AMS		 8483 else if (o->op_next->op_type == OP_READLINE
8484 && o->op_next->op_next->op_type == OP_CONCAT
8485 && (o->op_next->op_next->op_flags & OPf_STACKED))
8486 {
d2c45030
AMS		 8487 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8488 o->op_type = OP_RCATLINE;
8489 o->op_flags |= OPf_STACKED;
8490 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 8491 op_null(o->op_next->op_next);
d2c45030 8492 op_null(o->op_next);
89de2904 8493 }
76cd736e 8494
79072805 8495 break;
867fa1e2
YO		 8496
8497 {
8498 OP *fop;
8499 OP *sop;
8500
8501 case OP_NOT:
8502 fop = cUNOP->op_first;
8503 sop = NULL;
8504 goto stitch_keys;
8505 break;
8506
8507 case OP_AND:
79072805 8508 case OP_OR:
c963b151 8509 case OP_DOR:
867fa1e2
YO		 8510 fop = cLOGOP->op_first;
8511 sop = fop->op_sibling;
8512 while (cLOGOP->op_other->op_type == OP_NULL)
8513 cLOGOP->op_other = cLOGOP->op_other->op_next;
8514 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8515
8516 stitch_keys:
8517 o->op_opt = 1;
8518 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8519 || ( sop &&
8520 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8521 )
8522 ){
8523 OP * nop = o;
8524 OP * lop = o;
8525 if (!(nop->op_flags && OPf_WANT_VOID)) {
8526 while (nop && nop->op_next) {
8527 switch (nop->op_next->op_type) {
8528 case OP_NOT:
8529 case OP_AND:
8530 case OP_OR:
8531 case OP_DOR:
8532 lop = nop = nop->op_next;
8533 break;
8534 case OP_NULL:
8535 nop = nop->op_next;
8536 break;
8537 default:
8538 nop = NULL;
8539 break;
8540 }
8541 }
8542 }
8543 if (lop->op_flags && OPf_WANT_VOID) {
8544 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8545 cLOGOP->op_first = opt_scalarhv(fop);
8546 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8547 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8548 }
8549 }
8550
8551
8552 break;
8553 }
8554
8555 case OP_MAPWHILE:
8556 case OP_GREPWHILE:
2c2d71f5
JH		 8557 case OP_ANDASSIGN:
8558 case OP_ORASSIGN:
c963b151 8559 case OP_DORASSIGN:
1a67a97c
SM		 8560 case OP_COND_EXPR:
8561 case OP_RANGE:
c5917253 8562 case OP_ONCE:
fd4d1407
IZ		 8563 while (cLOGOP->op_other->op_type == OP_NULL)
8564 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 8565 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 8566 break;
8567
79072805 8568 case OP_ENTERLOOP:
9c2ca71a 8569 case OP_ENTERITER:
58cccf98
SM		 8570 while (cLOOP->op_redoop->op_type == OP_NULL)
8571 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 8572 peep(cLOOP->op_redoop);
58cccf98
SM		 8573 while (cLOOP->op_nextop->op_type == OP_NULL)
8574 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 8575 peep(cLOOP->op_nextop);
58cccf98
SM		 8576 while (cLOOP->op_lastop->op_type == OP_NULL)
8577 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 8578 peep(cLOOP->op_lastop);
8579 break;
8580
79072805 8581 case OP_SUBST:
29f2e912
NC		 8582 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8583 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8584 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8585 cPMOP->op_pmstashstartu.op_pmreplstart
8586 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8587 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 8588 break;
8589
a0d0e21e 8590 case OP_EXEC:
041457d9
DM		 8591 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8592 && ckWARN(WARN_SYNTAX))
8593 {
1496a290
AL		 8594 if (o->op_next->op_sibling) {
8595 const OPCODE type = o->op_next->op_sibling->op_type;
8596 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8597 const line_t oldline = CopLINE(PL_curcop);
8598 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8599 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8600 "Statement unlikely to be reached");
8601 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8602 "\t(Maybe you meant system() when you said exec()?)\n");
8603 CopLINE_set(PL_curcop, oldline);
8604 }
a0d0e21e
LW		 8605 }
8606 }
8607 break;
b2ffa427 8608
c750a3ec 8609 case OP_HELEM: {
e75d1f10 8610 UNOP *rop;
6d822dc4 8611 SV *lexname;
e75d1f10 8612 GV **fields;
6d822dc4 8613 SV **svp, *sv;
d5263905 8614 const char *key = NULL;
c750a3ec 8615 STRLEN keylen;
b2ffa427 8616
1c846c1f 8617 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 8618 break;
1c846c1f
NIS		 8619
8620 /* Make the CONST have a shared SV */
8621 svp = cSVOPx_svp(((BINOP*)o)->op_last);
38bb37b9 8622 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
d5263905 8623 key = SvPV_const(sv, keylen);
25716404 8624 lexname = newSVpvn_share(key,
bb7a0f54 8625 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
25716404 8626 0);
1c846c1f
NIS		 8627 SvREFCNT_dec(sv);
8628 *svp = lexname;
8629 }
e75d1f10
RD		 8630
8631 if ((o->op_private & (OPpLVAL_INTRO)))
8632 break;
8633
8634 rop = (UNOP*)((BINOP*)o)->op_first;
8635 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8636 break;
8637 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
00b1698f 8638 if (!SvPAD_TYPED(lexname))
e75d1f10 8639 break;
a4fc7abc 8640 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 8641 if (!fields || !GvHV(*fields))
8642 break;
93524f2b 8643 key = SvPV_const(*svp, keylen);
e75d1f10 8644 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 8645 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 8646 {
8647 Perl_croak(aTHX_ "No such class field \"%s\" "
8648 "in variable %s of type %s",
93524f2b 8649 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8650 }
8651
6d822dc4
MS		 8652 break;
8653 }
c750a3ec 8654
e75d1f10
RD		 8655 case OP_HSLICE: {
8656 UNOP *rop;
8657 SV *lexname;
8658 GV **fields;
8659 SV **svp;
93524f2b 8660 const char *key;
e75d1f10
RD		 8661 STRLEN keylen;
8662 SVOP *first_key_op, *key_op;
8663
8664 if ((o->op_private & (OPpLVAL_INTRO))
8665 /* I bet there's always a pushmark... */
8666 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8667 /* hmmm, no optimization if list contains only one key. */
8668 break;
8669 rop = (UNOP*)((LISTOP*)o)->op_last;
8670 if (rop->op_type != OP_RV2HV)
8671 break;
8672 if (rop->op_first->op_type == OP_PADSV)
8673 /* @$hash{qw(keys here)} */
8674 rop = (UNOP*)rop->op_first;
8675 else {
8676 /* @{$hash}{qw(keys here)} */
8677 if (rop->op_first->op_type == OP_SCOPE
8678 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8679 {
8680 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8681 }
8682 else
8683 break;
8684 }
8685
8686 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
00b1698f 8687 if (!SvPAD_TYPED(lexname))
e75d1f10 8688 break;
a4fc7abc 8689 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 8690 if (!fields || !GvHV(*fields))
8691 break;
8692 /* Again guessing that the pushmark can be jumped over.... */
8693 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8694 ->op_first->op_sibling;
8695 for (key_op = first_key_op; key_op;
8696 key_op = (SVOP*)key_op->op_sibling) {
8697 if (key_op->op_type != OP_CONST)
8698 continue;
8699 svp = cSVOPx_svp(key_op);
93524f2b 8700 key = SvPV_const(*svp, keylen);
e75d1f10 8701 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 8702 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 8703 {
8704 Perl_croak(aTHX_ "No such class field \"%s\" "
8705 "in variable %s of type %s",
bfcb3514 8706 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8707 }
8708 }
8709 break;
8710 }
8711
fe1bc4cf 8712 case OP_SORT: {
fe1bc4cf 8713 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
551405c4 8714 OP *oleft;
fe1bc4cf
DM		 8715 OP *o2;
8716
fe1bc4cf 8717 /* check that RHS of sort is a single plain array */
551405c4 8718 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 8719 if (!oright || oright->op_type != OP_PUSHMARK)
8720 break;
471178c0
NC		 8721
8722 /* reverse sort ... can be optimised. */
8723 if (!cUNOPo->op_sibling) {
8724 /* Nothing follows us on the list. */
551405c4 8725 OP * const reverse = o->op_next;
471178c0
NC		 8726
8727 if (reverse->op_type == OP_REVERSE &&
8728 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 8729 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 8730 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8731 && (cUNOPx(pushmark)->op_sibling == o)) {
8732 /* reverse -> pushmark -> sort */
8733 o->op_private |= OPpSORT_REVERSE;
8734 op_null(reverse);
8735 pushmark->op_next = oright->op_next;
8736 op_null(oright);
8737 }
8738 }
8739 }
8740
8741 /* make @a = sort @a act in-place */
8742
fe1bc4cf
DM		 8743 oright = cUNOPx(oright)->op_sibling;
8744 if (!oright)
8745 break;
8746 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8747 oright = cUNOPx(oright)->op_sibling;
8748 }
8749
8750 if (!oright ||
8751 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8752 || oright->op_next != o
8753 || (oright->op_private & OPpLVAL_INTRO)
8754 )
8755 break;
8756
8757 /* o2 follows the chain of op_nexts through the LHS of the
8758 * assign (if any) to the aassign op itself */
8759 o2 = o->op_next;
8760 if (!o2 || o2->op_type != OP_NULL)
8761 break;
8762 o2 = o2->op_next;
8763 if (!o2 || o2->op_type != OP_PUSHMARK)
8764 break;
8765 o2 = o2->op_next;
8766 if (o2 && o2->op_type == OP_GV)
8767 o2 = o2->op_next;
8768 if (!o2
8769 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8770 || (o2->op_private & OPpLVAL_INTRO)
8771 )
8772 break;
8773 oleft = o2;
8774 o2 = o2->op_next;
8775 if (!o2 || o2->op_type != OP_NULL)
8776 break;
8777 o2 = o2->op_next;
8778 if (!o2 || o2->op_type != OP_AASSIGN
8779 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8780 break;
8781
db7511db
DM		 8782 /* check that the sort is the first arg on RHS of assign */
8783
8784 o2 = cUNOPx(o2)->op_first;
8785 if (!o2 || o2->op_type != OP_NULL)
8786 break;
8787 o2 = cUNOPx(o2)->op_first;
8788 if (!o2 || o2->op_type != OP_PUSHMARK)
8789 break;
8790 if (o2->op_sibling != o)
8791 break;
8792
fe1bc4cf
DM		 8793 /* check the array is the same on both sides */
8794 if (oleft->op_type == OP_RV2AV) {
8795 if (oright->op_type != OP_RV2AV
8796 || !cUNOPx(oright)->op_first
8797 || cUNOPx(oright)->op_first->op_type != OP_GV
8798 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8799 cGVOPx_gv(cUNOPx(oright)->op_first)
8800 )
8801 break;
8802 }
8803 else if (oright->op_type != OP_PADAV
8804 || oright->op_targ != oleft->op_targ
8805 )
8806 break;
8807
8808 /* transfer MODishness etc from LHS arg to RHS arg */
8809 oright->op_flags = oleft->op_flags;
8810 o->op_private |= OPpSORT_INPLACE;
8811
8812 /* excise push->gv->rv2av->null->aassign */
8813 o2 = o->op_next->op_next;
8814 op_null(o2); /* PUSHMARK */
8815 o2 = o2->op_next;
8816 if (o2->op_type == OP_GV) {
8817 op_null(o2); /* GV */
8818 o2 = o2->op_next;
8819 }
8820 op_null(o2); /* RV2AV or PADAV */
8821 o2 = o2->op_next->op_next;
8822 op_null(o2); /* AASSIGN */
8823
8824 o->op_next = o2->op_next;
8825
8826 break;
8827 }
ef3e5ea9
NC		 8828
8829 case OP_REVERSE: {
e682d7b7 8830 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 8831 OP *gvop = NULL;
ef3e5ea9 8832 LISTOP *enter, *exlist;
ef3e5ea9
NC		 8833
8834 enter = (LISTOP *) o->op_next;
8835 if (!enter)
8836 break;
8837 if (enter->op_type == OP_NULL) {
8838 enter = (LISTOP *) enter->op_next;
8839 if (!enter)
8840 break;
8841 }
d46f46af
NC		 8842 /* for $a (...) will have OP_GV then OP_RV2GV here.
8843 for (...) just has an OP_GV. */
ce335f37
NC		 8844 if (enter->op_type == OP_GV) {
8845 gvop = (OP *) enter;
8846 enter = (LISTOP *) enter->op_next;
8847 if (!enter)
8848 break;
d46f46af
NC		 8849 if (enter->op_type == OP_RV2GV) {
8850 enter = (LISTOP *) enter->op_next;
8851 if (!enter)
ce335f37 8852 break;
d46f46af 8853 }
ce335f37
NC		 8854 }
8855
ef3e5ea9
NC		 8856 if (enter->op_type != OP_ENTERITER)
8857 break;
8858
8859 iter = enter->op_next;
8860 if (!iter || iter->op_type != OP_ITER)
8861 break;
8862
ce335f37
NC		 8863 expushmark = enter->op_first;
8864 if (!expushmark || expushmark->op_type != OP_NULL
8865 || expushmark->op_targ != OP_PUSHMARK)
8866 break;
8867
8868 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 8869 if (!exlist || exlist->op_type != OP_NULL
8870 || exlist->op_targ != OP_LIST)
8871 break;
8872
8873 if (exlist->op_last != o) {
8874 /* Mmm. Was expecting to point back to this op. */
8875 break;
8876 }
8877 theirmark = exlist->op_first;
8878 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8879 break;
8880
c491ecac 8881 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 8882 /* There's something between the mark and the reverse, eg
8883 for (1, reverse (...))
8884 so no go. */
8885 break;
8886 }
8887
c491ecac
NC		 8888 ourmark = ((LISTOP *)o)->op_first;
8889 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8890 break;
8891
ef3e5ea9
NC		 8892 ourlast = ((LISTOP *)o)->op_last;
8893 if (!ourlast || ourlast->op_next != o)
8894 break;
8895
e682d7b7
NC		 8896 rv2av = ourmark->op_sibling;
8897 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8898 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8899 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8900 /* We're just reversing a single array. */
8901 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8902 enter->op_flags |= OPf_STACKED;
8903 }
8904
ef3e5ea9
NC		 8905 /* We don't have control over who points to theirmark, so sacrifice
8906 ours. */
8907 theirmark->op_next = ourmark->op_next;
8908 theirmark->op_flags = ourmark->op_flags;
ce335f37 8909 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 8910 op_null(ourmark);
8911 op_null(o);
8912 enter->op_private |= OPpITER_REVERSED;
8913 iter->op_private |= OPpITER_REVERSED;
8914
8915 break;
8916 }
e26df76a
NC		 8917
8918 case OP_SASSIGN: {
8919 OP *rv2gv;
8920 UNOP *refgen, *rv2cv;
8921 LISTOP *exlist;
8922
50baa5ea 8923 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
de3370bc
NC		 8924 break;
8925
e26df76a
NC		 8926 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8927 break;
8928
8929 rv2gv = ((BINOP *)o)->op_last;
8930 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8931 break;
8932
8933 refgen = (UNOP *)((BINOP *)o)->op_first;
8934
8935 if (!refgen || refgen->op_type != OP_REFGEN)
8936 break;
8937
8938 exlist = (LISTOP *)refgen->op_first;
8939 if (!exlist || exlist->op_type != OP_NULL
8940 || exlist->op_targ != OP_LIST)
8941 break;
8942
8943 if (exlist->op_first->op_type != OP_PUSHMARK)
8944 break;
8945
8946 rv2cv = (UNOP*)exlist->op_last;
8947
8948 if (rv2cv->op_type != OP_RV2CV)
8949 break;
8950
8951 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8952 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8953 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8954
8955 o->op_private |= OPpASSIGN_CV_TO_GV;
8956 rv2gv->op_private |= OPpDONT_INIT_GV;
8957 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8958
8959 break;
8960 }
8961
fe1bc4cf 8962
0477511c
NC		 8963 case OP_QR:
8964 case OP_MATCH:
29f2e912
NC		 8965 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8966 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8967 }
79072805
LW		 8968 break;
8969 }
a0d0e21e 8970 oldop = o;
79072805 8971 }
a0d0e21e 8972 LEAVE;
79072805 8973}
beab0874 8974
cef6ea9d 8975const char*
1cb0ed9b 8976Perl_custom_op_name(pTHX_ const OP* o)
53e06cf0 8977{
97aff369 8978 dVAR;
e1ec3a88 8979 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8980 SV* keysv;
8981 HE* he;
8982
7918f24d
NC		 8983 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8984
53e06cf0 8985 if (!PL_custom_op_names) /* This probably shouldn't happen */
27da23d5 8986 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 8987
8988 keysv = sv_2mortal(newSViv(index));
8989
8990 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8991 if (!he)
27da23d5 8992 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 8993
8994 return SvPV_nolen(HeVAL(he));
8995}
8996
cef6ea9d 8997const char*
1cb0ed9b 8998Perl_custom_op_desc(pTHX_ const OP* o)
53e06cf0 8999{
97aff369 9000 dVAR;
e1ec3a88 9001 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 9002 SV* keysv;
9003 HE* he;
9004
7918f24d
NC		 9005 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9006
53e06cf0 9007 if (!PL_custom_op_descs)
27da23d5 9008 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 9009
9010 keysv = sv_2mortal(newSViv(index));
9011
9012 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9013 if (!he)
27da23d5 9014 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 9015
9016 return SvPV_nolen(HeVAL(he));
9017}
19e8ce8e 9018
beab0874
JT		 9019#include "XSUB.h"
9020
9021/* Efficient sub that returns a constant scalar value. */
9022static void
acfe0abc 9023const_sv_xsub(pTHX_ CV* cv)
beab0874 9024{
97aff369 9025 dVAR;
beab0874 9026 dXSARGS;
99ab892b 9027 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9cbac4c7 9028 if (items != 0) {
6f207bd3 9029 NOOP;
9cbac4c7 9030#if 0
fe13d51d 9031 /* diag_listed_as: SKIPME */
9cbac4c7 9032 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 9033 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 9034#endif
9035 }
99ab892b
NC		 9036 if (!sv) {
9037 XSRETURN(0);
9038 }
9a049f1c 9039 EXTEND(sp, 1);
99ab892b 9040 ST(0) = sv;
beab0874
JT		 9041 XSRETURN(1);
9042}
4946a0fa
NC		 9043
9044/*
9045 * Local variables:
9046 * c-indentation-style: bsd
9047 * c-basic-offset: 4
9048 * indent-tabs-mode: t
9049 * End:
9050 *
37442d52
RGS		 9051 * ex: set ts=8 sts=4 sw=4 noet:
9052 */
Unnamed repository; edit this file 'description' to name the repository.