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