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
Add ~~ and // to perlcheat.pod
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
1129b882
NC		 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805
LW		 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW		 9 */
10
11/*
4ac71550
TC		 12 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me.' --the Gaffer
17 *
18 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
79072805
LW		 19 */
20
166f8a29
DM		 21/* This file contains the functions that create, manipulate and optimize
22 * the OP structures that hold a compiled perl program.
23 *
24 * A Perl program is compiled into a tree of OPs. Each op contains
25 * structural pointers (eg to its siblings and the next op in the
26 * execution sequence), a pointer to the function that would execute the
27 * op, plus any data specific to that op. For example, an OP_CONST op
28 * points to the pp_const() function and to an SV containing the constant
29 * value. When pp_const() is executed, its job is to push that SV onto the
30 * stack.
31 *
32 * OPs are mainly created by the newFOO() functions, which are mainly
33 * called from the parser (in perly.y) as the code is parsed. For example
34 * the Perl code $a + $b * $c would cause the equivalent of the following
35 * to be called (oversimplifying a bit):
36 *
37 * newBINOP(OP_ADD, flags,
38 * newSVREF($a),
39 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * )
41 *
42 * Note that during the build of miniperl, a temporary copy of this file
43 * is made, called opmini.c.
44 */
ccfc67b7 45
61b743bb
DM		 46/*
47Perl's compiler is essentially a 3-pass compiler with interleaved phases:
48
49 A bottom-up pass
50 A top-down pass
51 An execution-order pass
52
53The bottom-up pass is represented by all the "newOP" routines and
54the ck_ routines. The bottom-upness is actually driven by yacc.
55So at the point that a ck_ routine fires, we have no idea what the
56context is, either upward in the syntax tree, or either forward or
57backward in the execution order. (The bottom-up parser builds that
58part of the execution order it knows about, but if you follow the "next"
59links around, you'll find it's actually a closed loop through the
ef9da979 60top level node.)
61b743bb
DM		 61
62Whenever the bottom-up parser gets to a node that supplies context to
63its components, it invokes that portion of the top-down pass that applies
64to that part of the subtree (and marks the top node as processed, so
65if a node further up supplies context, it doesn't have to take the
66plunge again). As a particular subcase of this, as the new node is
67built, it takes all the closed execution loops of its subcomponents
68and links them into a new closed loop for the higher level node. But
69it's still not the real execution order.
70
71The actual execution order is not known till we get a grammar reduction
72to a top-level unit like a subroutine or file that will be called by
73"name" rather than via a "next" pointer. At that point, we can call
74into peep() to do that code's portion of the 3rd pass. It has to be
75recursive, but it's recursive on basic blocks, not on tree nodes.
76*/
77
06e0342d 78/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC		 79 get the compile time state of %^H for that block. Storing %^H in every
80 block (or even COP) would be very expensive, so a different approach is
81 taken. The (running) state of %^H is serialised into a tree of HE-like
82 structs. Stores into %^H are chained onto the current leaf as a struct
83 refcounted_he * with the key and the value. Deletes from %^H are saved
84 with a value of PL_sv_placeholder. The state of %^H at any point can be
85 turned back into a regular HV by walking back up the tree from that point's
06e0342d 86 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC		 87 the rest into the HV structure, then removing the placeholders. Hence
88 memory is only used to store the %^H deltas from the enclosing COP, rather
89 than the entire %^H on each COP.
90
91 To cause actions on %^H to write out the serialisation records, it has
92 magic type 'H'. This magic (itself) does nothing, but its presence causes
93 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 94 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
34795b44 95 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
c28fe1ec
NC		 96 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
97 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC		 98*/
99
79072805 100#include "EXTERN.h"
864dbfa3 101#define PERL_IN_OP_C
79072805 102#include "perl.h"
77ca0c92 103#include "keywords.h"
79072805 104
a07e034d 105#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
f37b8c3f 106#define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
a2efc822 107
238a4c30
NIS		 108#if defined(PL_OP_SLAB_ALLOC)
109
f1fac472
NC		 110#ifdef PERL_DEBUG_READONLY_OPS
111# define PERL_SLAB_SIZE 4096
112# include <sys/mman.h>
113#endif
114
238a4c30
NIS		 115#ifndef PERL_SLAB_SIZE
116#define PERL_SLAB_SIZE 2048
117#endif
118
c7e45529 119void *
e91d68d5 120Perl_Slab_Alloc(pTHX_ size_t sz)
1c846c1f 121{
5186cc12 122 dVAR;
5a8e194f
NIS		 123 /*
124 * To make incrementing use count easy PL_OpSlab is an I32 *
125 * To make inserting the link to slab PL_OpPtr is I32 **
126 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
127 * Add an overhead for pointer to slab and round up as a number of pointers
128 */
129 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 130 if ((PL_OpSpace -= sz) < 0) {
f1fac472
NC		 131#ifdef PERL_DEBUG_READONLY_OPS
132 /* We need to allocate chunk by chunk so that we can control the VM
133 mapping */
5186cc12 134 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
f1fac472
NC		 135 MAP_ANON|MAP_PRIVATE, -1, 0);
136
137 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
138 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
139 PL_OpPtr));
140 if(PL_OpPtr == MAP_FAILED) {
141 perror("mmap failed");
142 abort();
143 }
144#else
277e868c
NC		 145
146 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
f1fac472 147#endif
083fcd59 148 if (!PL_OpPtr) {
238a4c30
NIS		 149 return NULL;
150 }
5a8e194f
NIS		 151 /* We reserve the 0'th I32 sized chunk as a use count */
152 PL_OpSlab = (I32 *) PL_OpPtr;
153 /* Reduce size by the use count word, and by the size we need.
154 * Latter is to mimic the '-=' in the if() above
155 */
156 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS		 157 /* Allocation pointer starts at the top.
158 Theory: because we build leaves before trunk allocating at end
159 means that at run time access is cache friendly upward
160 */
5a8e194f 161 PL_OpPtr += PERL_SLAB_SIZE;
f1fac472
NC		 162
163#ifdef PERL_DEBUG_READONLY_OPS
164 /* We remember this slab. */
165 /* This implementation isn't efficient, but it is simple. */
5186cc12 166 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
f1fac472
NC		 167 PL_slabs[PL_slab_count++] = PL_OpSlab;
168 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
169#endif
238a4c30
NIS		 170 }
171 assert( PL_OpSpace >= 0 );
172 /* Move the allocation pointer down */
173 PL_OpPtr -= sz;
5a8e194f 174 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS		 175 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
176 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 177 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS		 178 assert( *PL_OpSlab > 0 );
179 return (void *)(PL_OpPtr + 1);
180}
181
f1fac472
NC		 182#ifdef PERL_DEBUG_READONLY_OPS
183void
184Perl_pending_Slabs_to_ro(pTHX) {
185 /* Turn all the allocated op slabs read only. */
186 U32 count = PL_slab_count;
187 I32 **const slabs = PL_slabs;
188
189 /* Reset the array of pending OP slabs, as we're about to turn this lot
190 read only. Also, do it ahead of the loop in case the warn triggers,
191 and a warn handler has an eval */
192
f1fac472
NC		 193 PL_slabs = NULL;
194 PL_slab_count = 0;
195
196 /* Force a new slab for any further allocation. */
197 PL_OpSpace = 0;
198
199 while (count--) {
5892a4d4 200 void *const start = slabs[count];
f1fac472
NC		 201 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
202 if(mprotect(start, size, PROT_READ)) {
203 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
204 start, (unsigned long) size, errno);
205 }
206 }
5892a4d4
NC		 207
208 free(slabs);
f1fac472
NC		 209}
210
211STATIC void
212S_Slab_to_rw(pTHX_ void *op)
213{
214 I32 * const * const ptr = (I32 **) op;
215 I32 * const slab = ptr[-1];
7918f24d
NC		 216
217 PERL_ARGS_ASSERT_SLAB_TO_RW;
218
f1fac472
NC		 219 assert( ptr-1 > (I32 **) slab );
220 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
221 assert( *slab > 0 );
222 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
223 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
224 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
225 }
226}
fc97af9c
NC		 227
228OP *
229Perl_op_refcnt_inc(pTHX_ OP *o)
230{
231 if(o) {
232 Slab_to_rw(o);
233 ++o->op_targ;
234 }
235 return o;
236
237}
238
239PADOFFSET
240Perl_op_refcnt_dec(pTHX_ OP *o)
241{
7918f24d 242 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
fc97af9c
NC		 243 Slab_to_rw(o);
244 return --o->op_targ;
245}
f1fac472
NC		 246#else
247# define Slab_to_rw(op)
248#endif
249
c7e45529
AE		 250void
251Perl_Slab_Free(pTHX_ void *op)
238a4c30 252{
551405c4 253 I32 * const * const ptr = (I32 **) op;
aec46f14 254 I32 * const slab = ptr[-1];
7918f24d 255 PERL_ARGS_ASSERT_SLAB_FREE;
5a8e194f
NIS		 256 assert( ptr-1 > (I32 **) slab );
257 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30 258 assert( *slab > 0 );
f1fac472 259 Slab_to_rw(op);
238a4c30 260 if (--(*slab) == 0) {
7e4e8c89
NC		 261# ifdef NETWARE
262# define PerlMemShared PerlMem
263# endif
083fcd59 264
f1fac472 265#ifdef PERL_DEBUG_READONLY_OPS
782a40f1 266 U32 count = PL_slab_count;
f1fac472 267 /* Need to remove this slab from our list of slabs */
782a40f1 268 if (count) {
f1fac472
NC		 269 while (count--) {
270 if (PL_slabs[count] == slab) {
5186cc12 271 dVAR;
f1fac472
NC		 272 /* Found it. Move the entry at the end to overwrite it. */
273 DEBUG_m(PerlIO_printf(Perl_debug_log,
274 "Deallocate %p by moving %p from %lu to %lu\n",
275 PL_OpSlab,
276 PL_slabs[PL_slab_count - 1],
277 PL_slab_count, count));
278 PL_slabs[count] = PL_slabs[--PL_slab_count];
279 /* Could realloc smaller at this point, but probably not
280 worth it. */
fc97af9c
NC		 281 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
282 perror("munmap failed");
283 abort();
284 }
285 break;
f1fac472 286 }
f1fac472
NC		 287 }
288 }
289#else
083fcd59 290 PerlMemShared_free(slab);
f1fac472 291#endif
238a4c30
NIS		 292 if (slab == PL_OpSlab) {
293 PL_OpSpace = 0;
294 }
295 }
b7dc083c 296}
b7dc083c 297#endif
e50aee73 298/*
ce6f1cbc 299 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 300 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 301 */
11343788 302#define CHECKOP(type,o) \
ce6f1cbc 303 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 304 ? ( op_free((OP*)o), \
cb77fdf0 305 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 306 (OP*)0 ) \
fc0dc3b3 307 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 308
e6438c1a 309#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 310
8b6b16e7 311STATIC const char*
cea2e8a9 312S_gv_ename(pTHX_ GV *gv)
4633a7c4 313{
46c461b5 314 SV* const tmpsv = sv_newmortal();
7918f24d
NC		 315
316 PERL_ARGS_ASSERT_GV_ENAME;
317
bd61b366 318 gv_efullname3(tmpsv, gv, NULL);
8b6b16e7 319 return SvPV_nolen_const(tmpsv);
4633a7c4
LW		 320}
321
76e3520e 322STATIC OP *
cea2e8a9 323S_no_fh_allowed(pTHX_ OP *o)
79072805 324{
7918f24d
NC		 325 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
326
cea2e8a9 327 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 328 OP_DESC(o)));
11343788 329 return o;
79072805
LW		 330}
331
76e3520e 332STATIC OP *
bfed75c6 333S_too_few_arguments(pTHX_ OP *o, const char *name)
79072805 334{
7918f24d
NC		 335 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
336
cea2e8a9 337 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 338 return o;
79072805
LW		 339}
340
76e3520e 341STATIC OP *
bfed75c6 342S_too_many_arguments(pTHX_ OP *o, const char *name)
79072805 343{
7918f24d
NC		 344 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
345
cea2e8a9 346 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 347 return o;
79072805
LW		 348}
349
76e3520e 350STATIC void
6867be6d 351S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
8990e307 352{
7918f24d
NC		 353 PERL_ARGS_ASSERT_BAD_TYPE;
354
cea2e8a9 355 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 356 (int)n, name, t, OP_DESC(kid)));
8990e307
LW		 357}
358
7a52d87a 359STATIC void
6867be6d 360S_no_bareword_allowed(pTHX_ const OP *o)
7a52d87a 361{
7918f24d
NC		 362 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
363
eb8433b7
NC		 364 if (PL_madskills)
365 return; /* various ok barewords are hidden in extra OP_NULL */
5a844595 366 qerror(Perl_mess(aTHX_
35c1215d 367 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
be2597df 368 SVfARG(cSVOPo_sv)));
7a52d87a
GS		 369}
370
79072805
LW		 371/* "register" allocation */
372
373PADOFFSET
262cbcdb 374Perl_allocmy(pTHX_ const char *const name)
93a17b20 375{
97aff369 376 dVAR;
a0d0e21e 377 PADOFFSET off;
12bd6ede 378 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 379
7918f24d
NC		 380 PERL_ARGS_ASSERT_ALLOCMY;
381
59f00321 382 /* complain about "my $<special_var>" etc etc */
6b58708b 383 if (*name &&
3edf23ff 384 !(is_our ||
155aba94 385 isALPHA(name[1]) ||
39e02b42 386 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
6b58708b 387 (name[1] == '_' && (*name == '$' || name[2]))))
834a4ddd 388 {
6b58708b 389 /* name[2] is true if strlen(name) > 2 */
c4d0567e 390 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
aab6a793
NC		 391 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
392 name[0], toCTRL(name[1]), name + 2,
393 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 394 } else {
aab6a793
NC		 395 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
396 PL_parser->in_my == KEY_state ? "state" : "my"));
46fc3d4c 397 }
a0d0e21e 398 }
748a9306 399
dd2155a4 400 /* check for duplicate declaration */
3edf23ff 401 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
33b8ce05 402
dd2155a4 403 /* allocate a spare slot and store the name in that slot */
93a17b20 404
dd2155a4 405 off = pad_add_name(name,
12bd6ede 406 PL_parser->in_my_stash,
3edf23ff 407 (is_our
133706a6
RGS		 408 /* $_ is always in main::, even with our */
409 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 410 : NULL
dd2155a4 411 ),
952306ac 412 0, /* not fake */
12bd6ede 413 PL_parser->in_my == KEY_state
dd2155a4 414 );
a74073ad
DM		 415 /* anon sub prototypes contains state vars should always be cloned,
416 * otherwise the state var would be shared between anon subs */
417
418 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
419 CvCLONE_on(PL_compcv);
420
dd2155a4 421 return off;
79072805
LW		 422}
423
d2c837a0
DM		 424/* free the body of an op without examining its contents.
425 * Always use this rather than FreeOp directly */
426
4136a0f7 427static void
d2c837a0
DM		 428S_op_destroy(pTHX_ OP *o)
429{
430 if (o->op_latefree) {
431 o->op_latefreed = 1;
432 return;
433 }
434 FreeOp(o);
435}
436
c4bd3ae5
NC		 437#ifdef USE_ITHREADS
438# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
439#else
440# define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
441#endif
d2c837a0 442
79072805
LW		 443/* Destructor */
444
445void
864dbfa3 446Perl_op_free(pTHX_ OP *o)
79072805 447{
27da23d5 448 dVAR;
acb36ea4 449 OPCODE type;
79072805 450
85594c31 451 if (!o)
79072805 452 return;
670f3923
DM		 453 if (o->op_latefreed) {
454 if (o->op_latefree)
455 return;
456 goto do_free;
457 }
79072805 458
67566ccd 459 type = o->op_type;
7934575e 460 if (o->op_private & OPpREFCOUNTED) {
67566ccd 461 switch (type) {
7934575e
GS		 462 case OP_LEAVESUB:
463 case OP_LEAVESUBLV:
464 case OP_LEAVEEVAL:
465 case OP_LEAVE:
466 case OP_SCOPE:
467 case OP_LEAVEWRITE:
67566ccd
AL		 468 {
469 PADOFFSET refcnt;
7934575e 470 OP_REFCNT_LOCK;
4026c95a 471 refcnt = OpREFCNT_dec(o);
7934575e 472 OP_REFCNT_UNLOCK;
bfd0ff22
NC		 473 if (refcnt) {
474 /* Need to find and remove any pattern match ops from the list
475 we maintain for reset(). */
476 find_and_forget_pmops(o);
4026c95a 477 return;
67566ccd 478 }
bfd0ff22 479 }
7934575e
GS		 480 break;
481 default:
482 break;
483 }
484 }
485
f37b8c3f
VP		 486 /* Call the op_free hook if it has been set. Do it now so that it's called
487 * at the right time for refcounted ops, but still before all of the kids
488 * are freed. */
489 CALL_OPFREEHOOK(o);
490
11343788 491 if (o->op_flags & OPf_KIDS) {
6867be6d 492 register OP *kid, *nextkid;
11343788 493 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 494 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 495 op_free(kid);
85e6fe83 496 }
79072805 497 }
acb36ea4 498
fc97af9c
NC		 499#ifdef PERL_DEBUG_READONLY_OPS
500 Slab_to_rw(o);
501#endif
502
acb36ea4
GS		 503 /* COP* is not cleared by op_clear() so that we may track line
504 * numbers etc even after null() */
cc93af5f
RGS		 505 if (type == OP_NEXTSTATE || type == OP_DBSTATE
506 || (type == OP_NULL /* the COP might have been null'ed */
507 && ((OPCODE)o->op_targ == OP_NEXTSTATE
508 || (OPCODE)o->op_targ == OP_DBSTATE))) {
acb36ea4 509 cop_free((COP*)o);
3235b7a3 510 }
acb36ea4 511
c53f1caa
RU		 512 if (type == OP_NULL)
513 type = (OPCODE)o->op_targ;
514
acb36ea4 515 op_clear(o);
670f3923
DM		 516 if (o->op_latefree) {
517 o->op_latefreed = 1;
518 return;
519 }
520 do_free:
238a4c30 521 FreeOp(o);
4d494880
DM		 522#ifdef DEBUG_LEAKING_SCALARS
523 if (PL_op == o)
5f66b61c 524 PL_op = NULL;
4d494880 525#endif
acb36ea4 526}
79072805 527
93c66552
DM		 528void
529Perl_op_clear(pTHX_ OP *o)
acb36ea4 530{
13137afc 531
27da23d5 532 dVAR;
7918f24d
NC		 533
534 PERL_ARGS_ASSERT_OP_CLEAR;
535
eb8433b7
NC		 536#ifdef PERL_MAD
537 /* if (o->op_madprop && o->op_madprop->mad_next)
538 abort(); */
3cc8d589
NC		 539 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
540 "modification of a read only value" for a reason I can't fathom why.
541 It's the "" stringification of $_, where $_ was set to '' in a foreach
04a4d38e
NC		 542 loop, but it defies simplification into a small test case.
543 However, commenting them out has caused ext/List/Util/t/weak.t to fail
544 the last test. */
3cc8d589
NC		 545 /*
546 mad_free(o->op_madprop);
547 o->op_madprop = 0;
548 */
eb8433b7
NC		 549#endif
550
551 retry:
11343788 552 switch (o->op_type) {
acb36ea4 553 case OP_NULL: /* Was holding old type, if any. */
eb8433b7 554 if (PL_madskills && o->op_targ != OP_NULL) {
61a59f30 555 o->op_type = (Optype)o->op_targ;
eb8433b7
NC		 556 o->op_targ = 0;
557 goto retry;
558 }
acb36ea4 559 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 560 o->op_targ = 0;
a0d0e21e 561 break;
a6006777 562 default:
ac4c12e7 563 if (!(o->op_flags & OPf_REF)
0b94c7bb 564 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 565 break;
566 /* FALL THROUGH */
463ee0b2 567 case OP_GVSV:
79072805 568 case OP_GV:
a6006777 569 case OP_AELEMFAST:
6a077020
DM		 570 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
571 /* not an OP_PADAV replacement */
350de78d 572#ifdef USE_ITHREADS
6a077020
DM		 573 if (cPADOPo->op_padix > 0) {
574 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
575 * may still exist on the pad */
576 pad_swipe(cPADOPo->op_padix, TRUE);
577 cPADOPo->op_padix = 0;
578 }
350de78d 579#else
6a077020 580 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 581 cSVOPo->op_sv = NULL;
350de78d 582#endif
6a077020 583 }
79072805 584 break;
a1ae71d2 585 case OP_METHOD_NAMED:
79072805 586 case OP_CONST:
996c9baa 587 case OP_HINTSEVAL:
11343788 588 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 589 cSVOPo->op_sv = NULL;
3b1c21fa
AB		 590#ifdef USE_ITHREADS
591 /** Bug #15654
592 Even if op_clear does a pad_free for the target of the op,
6a077020 593 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 594 instead it lives on. This results in that it could be reused as
595 a target later on when the pad was reallocated.
596 **/
597 if(o->op_targ) {
598 pad_swipe(o->op_targ,1);
599 o->op_targ = 0;
600 }
601#endif
79072805 602 break;
748a9306
LW		 603 case OP_GOTO:
604 case OP_NEXT:
605 case OP_LAST:
606 case OP_REDO:
11343788 607 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 608 break;
609 /* FALL THROUGH */
a0d0e21e 610 case OP_TRANS:
acb36ea4 611 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
043e41b8
DM		 612#ifdef USE_ITHREADS
613 if (cPADOPo->op_padix > 0) {
614 pad_swipe(cPADOPo->op_padix, TRUE);
615 cPADOPo->op_padix = 0;
616 }
617#else
a0ed51b3 618 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 619 cSVOPo->op_sv = NULL;
043e41b8 620#endif
acb36ea4
GS		 621 }
622 else {
ea71c68d 623 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 624 cPVOPo->op_pv = NULL;
acb36ea4 625 }
a0d0e21e
LW		 626 break;
627 case OP_SUBST:
20e98b0f 628 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 629 goto clear_pmop;
748a9306 630 case OP_PUSHRE:
971a9dd3 631#ifdef USE_ITHREADS
20e98b0f 632 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
dd2155a4
DM		 633 /* No GvIN_PAD_off here, because other references may still
634 * exist on the pad */
20e98b0f 635 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3
GS		 636 }
637#else
ad64d0ec 638 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
971a9dd3
GS		 639#endif
640 /* FALL THROUGH */
a0d0e21e 641 case OP_MATCH:
8782bef2 642 case OP_QR:
971a9dd3 643clear_pmop:
c2b1997a 644 forget_pmop(cPMOPo, 1);
20e98b0f 645 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
9cddf794
NC		 646 /* we use the same protection as the "SAFE" version of the PM_ macros
647 * here since sv_clean_all might release some PMOPs
5f8cb046
DM		 648 * after PL_regex_padav has been cleared
649 * and the clearing of PL_regex_padav needs to
650 * happen before sv_clean_all
651 */
13137afc
AB		 652#ifdef USE_ITHREADS
653 if(PL_regex_pad) { /* We could be in destruction */
402d2eb1 654 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 655 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC		 656 PL_regex_pad[offset] = &PL_sv_undef;
657 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
658 sizeof(offset));
13137afc 659 }
9cddf794
NC		 660#else
661 ReREFCNT_dec(PM_GETRE(cPMOPo));
662 PM_SETRE(cPMOPo, NULL);
1eb1540c 663#endif
13137afc 664
a0d0e21e 665 break;
79072805
LW		 666 }
667
743e66e6 668 if (o->op_targ > 0) {
11343788 669 pad_free(o->op_targ);
743e66e6
GS		 670 o->op_targ = 0;
671 }
79072805
LW		 672}
673
76e3520e 674STATIC void
3eb57f73
HS		 675S_cop_free(pTHX_ COP* cop)
676{
7918f24d
NC		 677 PERL_ARGS_ASSERT_COP_FREE;
678
05ec9bb3
NIS		 679 CopFILE_free(cop);
680 CopSTASH_free(cop);
0453d815 681 if (! specialWARN(cop->cop_warnings))
72dc9ed5 682 PerlMemShared_free(cop->cop_warnings);
c28fe1ec 683 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
3eb57f73
HS		 684}
685
c2b1997a 686STATIC void
c4bd3ae5
NC		 687S_forget_pmop(pTHX_ PMOP *const o
688#ifdef USE_ITHREADS
689 , U32 flags
690#endif
691 )
c2b1997a
NC		 692{
693 HV * const pmstash = PmopSTASH(o);
7918f24d
NC		 694
695 PERL_ARGS_ASSERT_FORGET_PMOP;
696
c2b1997a 697 if (pmstash && !SvIS_FREED(pmstash)) {
ad64d0ec 698 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC		 699 if (mg) {
700 PMOP **const array = (PMOP**) mg->mg_ptr;
701 U32 count = mg->mg_len / sizeof(PMOP**);
702 U32 i = count;
703
704 while (i--) {
705 if (array[i] == o) {
706 /* Found it. Move the entry at the end to overwrite it. */
707 array[i] = array[--count];
708 mg->mg_len = count * sizeof(PMOP**);
709 /* Could realloc smaller at this point always, but probably
710 not worth it. Probably worth free()ing if we're the
711 last. */
712 if(!count) {
713 Safefree(mg->mg_ptr);
714 mg->mg_ptr = NULL;
715 }
716 break;
717 }
718 }
719 }
720 }
1cdf7faf
NC		 721 if (PL_curpm == o)
722 PL_curpm = NULL;
c4bd3ae5 723#ifdef USE_ITHREADS
c2b1997a
NC		 724 if (flags)
725 PmopSTASH_free(o);
c4bd3ae5 726#endif
c2b1997a
NC		 727}
728
bfd0ff22
NC		 729STATIC void
730S_find_and_forget_pmops(pTHX_ OP *o)
731{
7918f24d
NC		 732 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
733
bfd0ff22
NC		 734 if (o->op_flags & OPf_KIDS) {
735 OP *kid = cUNOPo->op_first;
736 while (kid) {
737 switch (kid->op_type) {
738 case OP_SUBST:
739 case OP_PUSHRE:
740 case OP_MATCH:
741 case OP_QR:
742 forget_pmop((PMOP*)kid, 0);
743 }
744 find_and_forget_pmops(kid);
745 kid = kid->op_sibling;
746 }
747 }
748}
749
93c66552
DM		 750void
751Perl_op_null(pTHX_ OP *o)
8990e307 752{
27da23d5 753 dVAR;
7918f24d
NC		 754
755 PERL_ARGS_ASSERT_OP_NULL;
756
acb36ea4
GS		 757 if (o->op_type == OP_NULL)
758 return;
eb8433b7
NC		 759 if (!PL_madskills)
760 op_clear(o);
11343788
MB		 761 o->op_targ = o->op_type;
762 o->op_type = OP_NULL;
22c35a8c 763 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 764}
765
4026c95a
SH		 766void
767Perl_op_refcnt_lock(pTHX)
768{
27da23d5 769 dVAR;
96a5add6 770 PERL_UNUSED_CONTEXT;
4026c95a
SH		 771 OP_REFCNT_LOCK;
772}
773
774void
775Perl_op_refcnt_unlock(pTHX)
776{
27da23d5 777 dVAR;
96a5add6 778 PERL_UNUSED_CONTEXT;
4026c95a
SH		 779 OP_REFCNT_UNLOCK;
780}
781
79072805
LW		 782/* Contextualizers */
783
463ee0b2 784#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805 785
1f676739 786static OP *
12e93c28 787S_linklist(pTHX_ OP *o)
79072805 788{
3edf23ff 789 OP *first;
79072805 790
7918f24d
NC		 791 PERL_ARGS_ASSERT_LINKLIST;
792
11343788
MB		 793 if (o->op_next)
794 return o->op_next;
79072805
LW		 795
796 /* establish postfix order */
3edf23ff
AL		 797 first = cUNOPo->op_first;
798 if (first) {
6867be6d 799 register OP *kid;
3edf23ff
AL		 800 o->op_next = LINKLIST(first);
801 kid = first;
802 for (;;) {
803 if (kid->op_sibling) {
79072805 804 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL		 805 kid = kid->op_sibling;
806 } else {
11343788 807 kid->op_next = o;
3edf23ff
AL		 808 break;
809 }
79072805
LW		 810 }
811 }
812 else
11343788 813 o->op_next = o;
79072805 814
11343788 815 return o->op_next;
79072805
LW		 816}
817
1f676739 818static OP *
2dd5337b 819S_scalarkids(pTHX_ OP *o)
79072805 820{
11343788 821 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 822 OP *kid;
11343788 823 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 824 scalar(kid);
825 }
11343788 826 return o;
79072805
LW		 827}
828
76e3520e 829STATIC OP *
cea2e8a9 830S_scalarboolean(pTHX_ OP *o)
8990e307 831{
97aff369 832 dVAR;
7918f24d
NC		 833
834 PERL_ARGS_ASSERT_SCALARBOOLEAN;
835
d008e5eb 836 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 837 if (ckWARN(WARN_SYNTAX)) {
6867be6d 838 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 839
53a7735b
DM		 840 if (PL_parser && PL_parser->copline != NOLINE)
841 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 842 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 843 CopLINE_set(PL_curcop, oldline);
d008e5eb 844 }
a0d0e21e 845 }
11343788 846 return scalar(o);
8990e307
LW		 847}
848
849OP *
864dbfa3 850Perl_scalar(pTHX_ OP *o)
79072805 851{
27da23d5 852 dVAR;
79072805
LW		 853 OP *kid;
854
a0d0e21e 855 /* assumes no premature commitment */
13765c85
DM		 856 if (!o || (PL_parser && PL_parser->error_count)
857 || (o->op_flags & OPf_WANT)
5dc0d613 858 || o->op_type == OP_RETURN)
7e363e51 859 {
11343788 860 return o;
7e363e51 861 }
79072805 862
5dc0d613 863 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 864
11343788 865 switch (o->op_type) {
79072805 866 case OP_REPEAT:
11343788 867 scalar(cBINOPo->op_first);
8990e307 868 break;
79072805
LW		 869 case OP_OR:
870 case OP_AND:
871 case OP_COND_EXPR:
11343788 872 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 873 scalar(kid);
79072805 874 break;
a0d0e21e 875 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 &&
d503a9ba 2773 SvPVX((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 *
d503a9ba 2930Perl_newMADPROP(pTHX_ char key, char type, 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()
76f108ac
JD		 3965method, similar to C<use Foo::Bar VERSION LIST>. They must be
3966terminated with a final NULL pointer. Note that this list can only
3967be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
3968Otherwise at least a single NULL pointer to designate the default
3969import list is required.
7d3fb230
BS		 3970
3971=cut */
3972
e4783991
GS		 3973void
3974Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3975{
3976 va_list args;
7918f24d
NC		 3977
3978 PERL_ARGS_ASSERT_LOAD_MODULE;
3979
e4783991
GS		 3980 va_start(args, ver);
3981 vload_module(flags, name, ver, &args);
3982 va_end(args);
3983}
3984
3985#ifdef PERL_IMPLICIT_CONTEXT
3986void
3987Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3988{
3989 dTHX;
3990 va_list args;
7918f24d 3991 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
e4783991
GS		 3992 va_start(args, ver);
3993 vload_module(flags, name, ver, &args);
3994 va_end(args);
3995}
3996#endif
3997
3998void
3999Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4000{
97aff369 4001 dVAR;
551405c4 4002 OP *veop, *imop;
551405c4 4003 OP * const modname = newSVOP(OP_CONST, 0, name);
7918f24d
NC		 4004
4005 PERL_ARGS_ASSERT_VLOAD_MODULE;
4006
e4783991
GS		 4007 modname->op_private |= OPpCONST_BARE;
4008 if (ver) {
4009 veop = newSVOP(OP_CONST, 0, ver);
4010 }
4011 else
5f66b61c 4012 veop = NULL;
e4783991
GS		 4013 if (flags & PERL_LOADMOD_NOIMPORT) {
4014 imop = sawparens(newNULLLIST());
4015 }
4016 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4017 imop = va_arg(*args, OP*);
4018 }
4019 else {
4020 SV *sv;
5f66b61c 4021 imop = NULL;
e4783991
GS		 4022 sv = va_arg(*args, SV*);
4023 while (sv) {
4024 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4025 sv = va_arg(*args, SV*);
4026 }
4027 }
81885997 4028
53a7735b
DM		 4029 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4030 * that it has a PL_parser to play with while doing that, and also
4031 * that it doesn't mess with any existing parser, by creating a tmp
4032 * new parser with lex_start(). This won't actually be used for much,
4033 * since pp_require() will create another parser for the real work. */
4034
4035 ENTER;
4036 SAVEVPTR(PL_curcop);
5486870f 4037 lex_start(NULL, NULL, FALSE);
53a7735b
DM		 4038 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4039 veop, modname, imop);
4040 LEAVE;
e4783991
GS		 4041}
4042
79072805 4043OP *
850e8516 4044Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 4045{
97aff369 4046 dVAR;
78ca652e 4047 OP *doop;
a0714e2c 4048 GV *gv = NULL;
78ca652e 4049
7918f24d
NC		 4050 PERL_ARGS_ASSERT_DOFILE;
4051
850e8516 4052 if (!force_builtin) {
fafc274c 4053 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
850e8516 4054 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 4055 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
a0714e2c 4056 gv = gvp ? *gvp : NULL;
850e8516
RGS		 4057 }
4058 }
78ca652e 4059
b9f751c0 4060 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 4061 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4062 append_elem(OP_LIST, term,
4063 scalar(newUNOP(OP_RV2CV, 0,
d4c19fe8 4064 newGVOP(OP_GV, 0, gv))))));
78ca652e
GS		 4065 }
4066 else {
4067 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4068 }
4069 return doop;
4070}
4071
4072OP *
864dbfa3 4073Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 4074{
4075 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 4076 list(force_list(subscript)),
4077 list(force_list(listval)) );
79072805
LW		 4078}
4079
76e3520e 4080STATIC I32
504618e9 4081S_is_list_assignment(pTHX_ register const OP *o)
79072805 4082{
1496a290
AL		 4083 unsigned type;
4084 U8 flags;
4085
11343788 4086 if (!o)
79072805
LW		 4087 return TRUE;
4088
1496a290 4089 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
11343788 4090 o = cUNOPo->op_first;
79072805 4091
1496a290
AL		 4092 flags = o->op_flags;
4093 type = o->op_type;
4094 if (type == OP_COND_EXPR) {
504618e9
AL		 4095 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4096 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 4097
4098 if (t && f)
4099 return TRUE;
4100 if (t || f)
4101 yyerror("Assignment to both a list and a scalar");
4102 return FALSE;
4103 }
4104
1496a290
AL		 4105 if (type == OP_LIST &&
4106 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
95f0a2f1
SB		 4107 o->op_private & OPpLVAL_INTRO)
4108 return FALSE;
4109
1496a290
AL		 4110 if (type == OP_LIST || flags & OPf_PARENS ||
4111 type == OP_RV2AV || type == OP_RV2HV ||
4112 type == OP_ASLICE || type == OP_HSLICE)
79072805
LW		 4113 return TRUE;
4114
1496a290 4115 if (type == OP_PADAV || type == OP_PADHV)
93a17b20
LW		 4116 return TRUE;
4117
1496a290 4118 if (type == OP_RV2SV)
79072805
LW		 4119 return FALSE;
4120
4121 return FALSE;
4122}
4123
4124OP *
864dbfa3 4125Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 4126{
97aff369 4127 dVAR;
11343788 4128 OP *o;
79072805 4129
a0d0e21e 4130 if (optype) {
c963b151 4131 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW		 4132 return newLOGOP(optype, 0,
4133 mod(scalar(left), optype),
4134 newUNOP(OP_SASSIGN, 0, scalar(right)));
4135 }
4136 else {
4137 return newBINOP(optype, OPf_STACKED,
4138 mod(scalar(left), optype), scalar(right));
4139 }
4140 }
4141
504618e9 4142 if (is_list_assignment(left)) {
6dbe9451
NC		 4143 static const char no_list_state[] = "Initialization of state variables"
4144 " in list context currently forbidden";
10c8fecd 4145 OP *curop;
fafafbaf 4146 bool maybe_common_vars = TRUE;
10c8fecd 4147
3280af22 4148 PL_modcount = 0;
dbfe47cf
RD		 4149 /* Grandfathering $[ assignment here. Bletch.*/
4150 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
fe5bfecd 4151 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
463ee0b2 4152 left = mod(left, OP_AASSIGN);
3280af22
NIS		 4153 if (PL_eval_start)
4154 PL_eval_start = 0;
dbfe47cf 4155 else if (left->op_type == OP_CONST) {
eb8433b7 4156 /* FIXME for MAD */
dbfe47cf
RD		 4157 /* Result of assignment is always 1 (or we'd be dead already) */
4158 return newSVOP(OP_CONST, 0, newSViv(1));
a0d0e21e 4159 }
10c8fecd
GS		 4160 curop = list(force_list(left));
4161 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 4162 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4 4163
fafafbaf
RD		 4164 if ((left->op_type == OP_LIST
4165 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4166 {
4167 OP* lop = ((LISTOP*)left)->op_first;
4168 maybe_common_vars = FALSE;
4169 while (lop) {
4170 if (lop->op_type == OP_PADSV ||
4171 lop->op_type == OP_PADAV ||
4172 lop->op_type == OP_PADHV ||
4173 lop->op_type == OP_PADANY) {
4174 if (!(lop->op_private & OPpLVAL_INTRO))
4175 maybe_common_vars = TRUE;
4176
4177 if (lop->op_private & OPpPAD_STATE) {
4178 if (left->op_private & OPpLVAL_INTRO) {
4179 /* Each variable in state($a, $b, $c) = ... */
4180 }
4181 else {
4182 /* Each state variable in
4183 (state $a, my $b, our $c, $d, undef) = ... */
4184 }
4185 yyerror(no_list_state);
4186 } else {
4187 /* Each my variable in
4188 (state $a, my $b, our $c, $d, undef) = ... */
4189 }
4190 } else if (lop->op_type == OP_UNDEF ||
4191 lop->op_type == OP_PUSHMARK) {
4192 /* undef may be interesting in
4193 (state $a, undef, state $c) */
4194 } else {
4195 /* Other ops in the list. */
4196 maybe_common_vars = TRUE;
4197 }
4198 lop = lop->op_sibling;
4199 }
4200 }
4201 else if ((left->op_private & OPpLVAL_INTRO)
4202 && ( left->op_type == OP_PADSV
4203 || left->op_type == OP_PADAV
4204 || left->op_type == OP_PADHV
4205 || left->op_type == OP_PADANY))
4206 {
4207 maybe_common_vars = FALSE;
4208 if (left->op_private & OPpPAD_STATE) {
4209 /* All single variable list context state assignments, hence
4210 state ($a) = ...
4211 (state $a) = ...
4212 state @a = ...
4213 state (@a) = ...
4214 (state @a) = ...
4215 state %a = ...
4216 state (%a) = ...
4217 (state %a) = ...
4218 */
4219 yyerror(no_list_state);
4220 }
4221 }
4222
dd2155a4
DM		 4223 /* PL_generation sorcery:
4224 * an assignment like ($a,$b) = ($c,$d) is easier than
4225 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4226 * To detect whether there are common vars, the global var
4227 * PL_generation is incremented for each assign op we compile.
4228 * Then, while compiling the assign op, we run through all the
4229 * variables on both sides of the assignment, setting a spare slot
4230 * in each of them to PL_generation. If any of them already have
4231 * that value, we know we've got commonality. We could use a
4232 * single bit marker, but then we'd have to make 2 passes, first
4233 * to clear the flag, then to test and set it. To find somewhere
931b58fb 4234 * to store these values, evil chicanery is done with SvUVX().
dd2155a4
DM		 4235 */
4236
fafafbaf 4237 if (maybe_common_vars) {
11343788 4238 OP *lastop = o;
3280af22 4239 PL_generation++;
11343788 4240 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 4241 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 4242 if (curop->op_type == OP_GV) {
638eceb6 4243 GV *gv = cGVOPx_gv(curop);
169d2d72
NC		 4244 if (gv == PL_defgv
4245 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
79072805 4246 break;
169d2d72 4247 GvASSIGN_GENERATION_set(gv, PL_generation);
79072805 4248 }
748a9306
LW		 4249 else if (curop->op_type == OP_PADSV ||
4250 curop->op_type == OP_PADAV ||
4251 curop->op_type == OP_PADHV ||
dd2155a4
DM		 4252 curop->op_type == OP_PADANY)
4253 {
4254 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 4255 == (STRLEN)PL_generation)
748a9306 4256 break;
b162af07 4257 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
dd2155a4 4258
748a9306 4259 }
79072805
LW		 4260 else if (curop->op_type == OP_RV2CV)
4261 break;
4262 else if (curop->op_type == OP_RV2SV ||
4263 curop->op_type == OP_RV2AV ||
4264 curop->op_type == OP_RV2HV ||
4265 curop->op_type == OP_RV2GV) {
4266 if (lastop->op_type != OP_GV) /* funny deref? */
4267 break;
4268 }
1167e5da 4269 else if (curop->op_type == OP_PUSHRE) {
b3f5893f 4270#ifdef USE_ITHREADS
20e98b0f 4271 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
159b6efe 4272 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
169d2d72
NC		 4273 if (gv == PL_defgv
4274 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
1167e5da 4275 break;
169d2d72 4276 GvASSIGN_GENERATION_set(gv, PL_generation);
20e98b0f
NC		 4277 }
4278#else
4279 GV *const gv
4280 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4281 if (gv) {
4282 if (gv == PL_defgv
4283 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4284 break;
169d2d72 4285 GvASSIGN_GENERATION_set(gv, PL_generation);
b2ffa427 4286 }
20e98b0f 4287#endif
1167e5da 4288 }
79072805
LW		 4289 else
4290 break;
4291 }
4292 lastop = curop;
4293 }
11343788 4294 if (curop != o)
10c8fecd 4295 o->op_private |= OPpASSIGN_COMMON;
461824dc 4296 }
9fdc7570 4297
e9cc17ba 4298 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
1496a290
AL		 4299 OP* tmpop = ((LISTOP*)right)->op_first;
4300 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
551405c4 4301 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 4302 if (left->op_type == OP_RV2AV &&
4303 !(left->op_private & OPpLVAL_INTRO) &&
11343788 4304 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 4305 {
4306 tmpop = ((UNOP*)left)->op_first;
20e98b0f
NC		 4307 if (tmpop->op_type == OP_GV
4308#ifdef USE_ITHREADS
4309 && !pm->op_pmreplrootu.op_pmtargetoff
4310#else
4311 && !pm->op_pmreplrootu.op_pmtargetgv
4312#endif
4313 ) {
971a9dd3 4314#ifdef USE_ITHREADS
20e98b0f
NC		 4315 pm->op_pmreplrootu.op_pmtargetoff
4316 = cPADOPx(tmpop)->op_padix;
971a9dd3
GS		 4317 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4318#else
20e98b0f 4319 pm->op_pmreplrootu.op_pmtargetgv
159b6efe 4320 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
a0714e2c 4321 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 4322#endif
c07a80fd 4323 pm->op_pmflags |= PMf_ONCE;
11343788 4324 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 4325 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 4326 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 4327 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 4328 op_free(o); /* blow off assign */
54310121 4329 right->op_flags &= ~OPf_WANT;
a5f75d66 4330 /* "I don't know and I don't care." */
c07a80fd 4331 return right;
4332 }
4333 }
4334 else {
e6438c1a 4335 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 4336 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4337 {
4338 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
b8de32d5 4339 if (SvIOK(sv) && SvIVX(sv) == 0)
3280af22 4340 sv_setiv(sv, PL_modcount+1);
c07a80fd 4341 }
4342 }
4343 }
4344 }
11343788 4345 return o;
79072805
LW		 4346 }
4347 if (!right)
4348 right = newOP(OP_UNDEF, 0);
4349 if (right->op_type == OP_READLINE) {
4350 right->op_flags |= OPf_STACKED;
463ee0b2 4351 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 4352 }
a0d0e21e 4353 else {
3280af22 4354 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 4355 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 4356 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 4357 if (PL_eval_start)
4358 PL_eval_start = 0;
748a9306 4359 else {
27aaedc1 4360 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
55b67815 4361 deprecate("assignment to $[");
27aaedc1
GG		 4362 op_free(o);
4363 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4364 o->op_private |= OPpCONST_ARYBASE;
4365 }
a0d0e21e
LW		 4366 }
4367 }
11343788 4368 return o;
79072805
LW		 4369}
4370
4371OP *
864dbfa3 4372Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 4373{
27da23d5 4374 dVAR;
e1ec3a88 4375 const U32 seq = intro_my();
79072805
LW		 4376 register COP *cop;
4377
b7dc083c 4378 NewOp(1101, cop, 1, COP);
57843af0 4379 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 4380 cop->op_type = OP_DBSTATE;
22c35a8c 4381 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 4382 }
4383 else {
4384 cop->op_type = OP_NEXTSTATE;
22c35a8c 4385 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 4386 }
eb160463 4387 cop->op_flags = (U8)flags;
623e6609 4388 CopHINTS_set(cop, PL_hints);
ff0cee69 4389#ifdef NATIVE_HINTS
4390 cop->op_private |= NATIVE_HINTS;
4391#endif
623e6609 4392 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 4393 cop->op_next = (OP*)cop;
4394
bbce6d69 4395 cop->cop_seq = seq;
7b0bddfa 4396 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
c28fe1ec
NC		 4397 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4398 */
72dc9ed5 4399 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
c28fe1ec
NC		 4400 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4401 if (cop->cop_hints_hash) {
cbb1fbea 4402 HINTS_REFCNT_LOCK;
c28fe1ec 4403 cop->cop_hints_hash->refcounted_he_refcnt++;
cbb1fbea 4404 HINTS_REFCNT_UNLOCK;
b3ca2e83 4405 }
dca6062a 4406 if (label) {
dca6062a 4407 cop->cop_hints_hash
012da8e5 4408 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
dca6062a
NC		 4409
4410 PL_hints |= HINT_BLOCK_SCOPE;
4411 /* It seems that we need to defer freeing this pointer, as other parts
4412 of the grammar end up wanting to copy it after this op has been
4413 created. */
4414 SAVEFREEPV(label);
dca6062a 4415 }
79072805 4416
53a7735b 4417 if (PL_parser && PL_parser->copline == NOLINE)
57843af0 4418 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 4419 else {
53a7735b
DM		 4420 CopLINE_set(cop, PL_parser->copline);
4421 if (PL_parser)
4422 PL_parser->copline = NOLINE;
79072805 4423 }
57843af0 4424#ifdef USE_ITHREADS
f4dd75d9 4425 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 4426#else
f4dd75d9 4427 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 4428#endif
11faa288 4429 CopSTASH_set(cop, PL_curstash);
79072805 4430
65269a95
TB		 4431 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4432 /* this line can have a breakpoint - store the cop in IV */
80a702cd
RGS		 4433 AV *av = CopFILEAVx(PL_curcop);
4434 if (av) {
4435 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4436 if (svp && *svp != &PL_sv_undef ) {
4437 (void)SvIOK_on(*svp);
4438 SvIV_set(*svp, PTR2IV(cop));
4439 }
1eb1540c 4440 }
93a17b20
LW		 4441 }
4442
f6f3a1fe
RGS		 4443 if (flags & OPf_SPECIAL)
4444 op_null((OP*)cop);
722969e2 4445 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 4446}
4447
bbce6d69 4448
79072805 4449OP *
864dbfa3 4450Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 4451{
27da23d5 4452 dVAR;
7918f24d
NC		 4453
4454 PERL_ARGS_ASSERT_NEWLOGOP;
4455
883ffac3
CS		 4456 return new_logop(type, flags, &first, &other);
4457}
4458
3bd495df 4459STATIC OP *
71c4dbc3
VP		 4460S_search_const(pTHX_ OP *o)
4461{
4462 PERL_ARGS_ASSERT_SEARCH_CONST;
4463
4464 switch (o->op_type) {
4465 case OP_CONST:
4466 return o;
4467 case OP_NULL:
4468 if (o->op_flags & OPf_KIDS)
4469 return search_const(cUNOPo->op_first);
4470 break;
4471 case OP_LEAVE:
4472 case OP_SCOPE:
4473 case OP_LINESEQ:
4474 {
4475 OP *kid;
4476 if (!(o->op_flags & OPf_KIDS))
4477 return NULL;
4478 kid = cLISTOPo->op_first;
4479 do {
4480 switch (kid->op_type) {
4481 case OP_ENTER:
4482 case OP_NULL:
4483 case OP_NEXTSTATE:
4484 kid = kid->op_sibling;
4485 break;
4486 default:
4487 if (kid != cLISTOPo->op_last)
4488 return NULL;
4489 goto last;
4490 }
4491 } while (kid);
4492 if (!kid)
4493 kid = cLISTOPo->op_last;
4494last:
4495 return search_const(kid);
4496 }
4497 }
4498
4499 return NULL;
4500}
4501
4502STATIC OP *
cea2e8a9 4503S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 4504{
27da23d5 4505 dVAR;
79072805 4506 LOGOP *logop;
11343788 4507 OP *o;
71c4dbc3
VP		 4508 OP *first;
4509 OP *other;
4510 OP *cstop = NULL;
edbe35ea 4511 int prepend_not = 0;
79072805 4512
7918f24d
NC		 4513 PERL_ARGS_ASSERT_NEW_LOGOP;
4514
71c4dbc3
VP		 4515 first = *firstp;
4516 other = *otherp;
4517
a0d0e21e
LW		 4518 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4519 return newBINOP(type, flags, scalar(first), scalar(other));
4520
8990e307 4521 scalarboolean(first);
edbe35ea 4522 /* optimize AND and OR ops that have NOTs as children */
68726e16 4523 if (first->op_type == OP_NOT
b6214b80 4524 && (first->op_flags & OPf_KIDS)
edbe35ea
VP		 4525 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4526 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
b6214b80 4527 && !PL_madskills) {
79072805
LW		 4528 if (type == OP_AND || type == OP_OR) {
4529 if (type == OP_AND)
4530 type = OP_OR;
4531 else
4532 type = OP_AND;
07f3cdf5 4533 op_null(first);
edbe35ea 4534 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
07f3cdf5 4535 op_null(other);
edbe35ea
VP		 4536 prepend_not = 1; /* prepend a NOT op later */
4537 }
79072805
LW		 4538 }
4539 }
71c4dbc3
VP		 4540 /* search for a constant op that could let us fold the test */
4541 if ((cstop = search_const(first))) {
4542 if (cstop->op_private & OPpCONST_STRICT)
4543 no_bareword_allowed(cstop);
4544 else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
989dfb19 4545 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
71c4dbc3
VP		 4546 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4547 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4548 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5f66b61c 4549 *firstp = NULL;
d6fee5c7
DM		 4550 if (other->op_type == OP_CONST)
4551 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4552 if (PL_madskills) {
4553 OP *newop = newUNOP(OP_NULL, 0, other);
4554 op_getmad(first, newop, '1');
4555 newop->op_targ = type; /* set "was" field */
4556 return newop;
4557 }
4558 op_free(first);
dd3e51dc
VP		 4559 if (other->op_type == OP_LEAVE)
4560 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
79072805
LW		 4561 return other;
4562 }
4563 else {
7921d0f2 4564 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 4565 const OP *o2 = other;
7921d0f2
DM		 4566 if ( ! (o2->op_type == OP_LIST
4567 && (( o2 = cUNOPx(o2)->op_first))
4568 && o2->op_type == OP_PUSHMARK
4569 && (( o2 = o2->op_sibling)) )
4570 )
4571 o2 = other;
4572 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4573 || o2->op_type == OP_PADHV)
4574 && o2->op_private & OPpLVAL_INTRO
52351015 4575 && !(o2->op_private & OPpPAD_STATE)
7921d0f2
DM		 4576 && ckWARN(WARN_DEPRECATED))
4577 {
4578 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4579 "Deprecated use of my() in false conditional");
4580 }
4581
5f66b61c 4582 *otherp = NULL;
d6fee5c7
DM		 4583 if (first->op_type == OP_CONST)
4584 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4585 if (PL_madskills) {
4586 first = newUNOP(OP_NULL, 0, first);
4587 op_getmad(other, first, '2');
4588 first->op_targ = type; /* set "was" field */
4589 }
4590 else
4591 op_free(other);
79072805
LW		 4592 return first;
4593 }
4594 }
041457d9
DM		 4595 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4596 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 4597 {
b22e6366
AL		 4598 const OP * const k1 = ((UNOP*)first)->op_first;
4599 const OP * const k2 = k1->op_sibling;
a6006777 4600 OPCODE warnop = 0;
4601 switch (first->op_type)
4602 {
4603 case OP_NULL:
4604 if (k2 && k2->op_type == OP_READLINE
4605 && (k2->op_flags & OPf_STACKED)
1c846c1f 4606 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 4607 {
a6006777 4608 warnop = k2->op_type;
72b16652 4609 }
a6006777 4610 break;
4611
4612 case OP_SASSIGN:
68dc0745 4613 if (k1->op_type == OP_READDIR
4614 || k1->op_type == OP_GLOB
72b16652 4615 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 4616 || k1->op_type == OP_EACH)
72b16652
GS		 4617 {
4618 warnop = ((k1->op_type == OP_NULL)
eb160463 4619 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 4620 }
a6006777 4621 break;
4622 }
8ebc5c01 4623 if (warnop) {
6867be6d 4624 const line_t oldline = CopLINE(PL_curcop);
53a7735b 4625 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 4626 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 4627 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 4628 PL_op_desc[warnop],
68dc0745 4629 ((warnop == OP_READLINE || warnop == OP_GLOB)
4630 ? " construct" : "() operator"));
57843af0 4631 CopLINE_set(PL_curcop, oldline);
8ebc5c01 4632 }
a6006777 4633 }
79072805
LW		 4634
4635 if (!other)
4636 return first;
4637
c963b151 4638 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 4639 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4640
b7dc083c 4641 NewOp(1101, logop, 1, LOGOP);
79072805 4642
eb160463 4643 logop->op_type = (OPCODE)type;
22c35a8c 4644 logop->op_ppaddr = PL_ppaddr[type];
79072805 4645 logop->op_first = first;
585ec06d 4646 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 4647 logop->op_other = LINKLIST(other);
eb160463 4648 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4649
4650 /* establish postfix order */
4651 logop->op_next = LINKLIST(first);
4652 first->op_next = (OP*)logop;
4653 first->op_sibling = other;
4654
463d09e6
RGS		 4655 CHECKOP(type,logop);
4656
edbe35ea 4657 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
11343788 4658 other->op_next = o;
79072805 4659
11343788 4660 return o;
79072805
LW		 4661}
4662
4663OP *
864dbfa3 4664Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 4665{
27da23d5 4666 dVAR;
1a67a97c
SM		 4667 LOGOP *logop;
4668 OP *start;
11343788 4669 OP *o;
71c4dbc3 4670 OP *cstop;
79072805 4671
7918f24d
NC		 4672 PERL_ARGS_ASSERT_NEWCONDOP;
4673
b1cb66bf 4674 if (!falseop)
4675 return newLOGOP(OP_AND, 0, first, trueop);
4676 if (!trueop)
4677 return newLOGOP(OP_OR, 0, first, falseop);
79072805 4678
8990e307 4679 scalarboolean(first);
71c4dbc3 4680 if ((cstop = search_const(first))) {
5b6782b2 4681 /* Left or right arm of the conditional? */
71c4dbc3 4682 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5b6782b2
NC		 4683 OP *live = left ? trueop : falseop;
4684 OP *const dead = left ? falseop : trueop;
71c4dbc3
VP		 4685 if (cstop->op_private & OPpCONST_BARE &&
4686 cstop->op_private & OPpCONST_STRICT) {
4687 no_bareword_allowed(cstop);
b22e6366 4688 }
5b6782b2
NC		 4689 if (PL_madskills) {
4690 /* This is all dead code when PERL_MAD is not defined. */
4691 live = newUNOP(OP_NULL, 0, live);
4692 op_getmad(first, live, 'C');
4693 op_getmad(dead, live, left ? 'e' : 't');
4694 } else {
4695 op_free(first);
4696 op_free(dead);
79072805 4697 }
ef9da979
FC		 4698 if (live->op_type == OP_LEAVE)
4699 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5b6782b2 4700 return live;
79072805 4701 }
1a67a97c
SM		 4702 NewOp(1101, logop, 1, LOGOP);
4703 logop->op_type = OP_COND_EXPR;
4704 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4705 logop->op_first = first;
585ec06d 4706 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 4707 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 4708 logop->op_other = LINKLIST(trueop);
4709 logop->op_next = LINKLIST(falseop);
79072805 4710
463d09e6
RGS		 4711 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4712 logop);
79072805
LW		 4713
4714 /* establish postfix order */
1a67a97c
SM		 4715 start = LINKLIST(first);
4716 first->op_next = (OP*)logop;
79072805 4717
b1cb66bf 4718 first->op_sibling = trueop;
4719 trueop->op_sibling = falseop;
1a67a97c 4720 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 4721
1a67a97c 4722 trueop->op_next = falseop->op_next = o;
79072805 4723
1a67a97c 4724 o->op_next = start;
11343788 4725 return o;
79072805
LW		 4726}
4727
4728OP *
864dbfa3 4729Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 4730{
27da23d5 4731 dVAR;
1a67a97c 4732 LOGOP *range;
79072805
LW		 4733 OP *flip;
4734 OP *flop;
1a67a97c 4735 OP *leftstart;
11343788 4736 OP *o;
79072805 4737
7918f24d
NC		 4738 PERL_ARGS_ASSERT_NEWRANGE;
4739
1a67a97c 4740 NewOp(1101, range, 1, LOGOP);
79072805 4741
1a67a97c
SM		 4742 range->op_type = OP_RANGE;
4743 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4744 range->op_first = left;
4745 range->op_flags = OPf_KIDS;
4746 leftstart = LINKLIST(left);
4747 range->op_other = LINKLIST(right);
eb160463 4748 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4749
4750 left->op_sibling = right;
4751
1a67a97c
SM		 4752 range->op_next = (OP*)range;
4753 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 4754 flop = newUNOP(OP_FLOP, 0, flip);
11343788 4755 o = newUNOP(OP_NULL, 0, flop);
79072805 4756 linklist(flop);
1a67a97c 4757 range->op_next = leftstart;
79072805
LW		 4758
4759 left->op_next = flip;
4760 right->op_next = flop;
4761
1a67a97c
SM		 4762 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4763 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 4764 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 4765 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4766
4767 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4768 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4769
11343788 4770 flip->op_next = o;
79072805 4771 if (!flip->op_private || !flop->op_private)
11343788 4772 linklist(o); /* blow off optimizer unless constant */
79072805 4773
11343788 4774 return o;
79072805
LW		 4775}
4776
4777OP *
864dbfa3 4778Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 4779{
97aff369 4780 dVAR;
463ee0b2 4781 OP* listop;
11343788 4782 OP* o;
73d840c0 4783 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 4784 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 4785
4786 PERL_UNUSED_ARG(debuggable);
93a17b20 4787
463ee0b2
LW		 4788 if (expr) {
4789 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4790 return block; /* do {} while 0 does once */
fb73857a 4791 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4792 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 4793 expr = newUNOP(OP_DEFINED, 0,
54b9620d 4794 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 4795 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 4796 const OP * const k1 = ((UNOP*)expr)->op_first;
4797 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 4798 switch (expr->op_type) {
1c846c1f 4799 case OP_NULL:
55d729e4
GS		 4800 if (k2 && k2->op_type == OP_READLINE
4801 && (k2->op_flags & OPf_STACKED)
1c846c1f 4802 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 4803 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 4804 break;
55d729e4
GS		 4805
4806 case OP_SASSIGN:
06dc7ac6 4807 if (k1 && (k1->op_type == OP_READDIR
55d729e4 4808 || k1->op_type == OP_GLOB
6531c3e6 4809 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
06dc7ac6 4810 || k1->op_type == OP_EACH))
55d729e4
GS		 4811 expr = newUNOP(OP_DEFINED, 0, expr);
4812 break;
4813 }
774d564b 4814 }
463ee0b2 4815 }
93a17b20 4816
e1548254
RGS		 4817 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4818 * op, in listop. This is wrong. [perl #27024] */
4819 if (!block)
4820 block = newOP(OP_NULL, 0);
8990e307 4821 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 4822 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 4823
883ffac3
CS		 4824 if (listop)
4825 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 4826
11343788
MB		 4827 if (once && o != listop)
4828 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 4829
11343788
MB		 4830 if (o == listop)
4831 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 4832
11343788
MB		 4833 o->op_flags |= flags;
4834 o = scope(o);
4835 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4836 return o;
79072805
LW		 4837}
4838
4839OP *
a034e688
DM		 4840Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4841whileline, OP *expr, OP *block, OP *cont, I32 has_my)
79072805 4842{
27da23d5 4843 dVAR;
79072805 4844 OP *redo;
c445ea15 4845 OP *next = NULL;
79072805 4846 OP *listop;
11343788 4847 OP *o;
1ba6ee2b 4848 U8 loopflags = 0;
46c461b5
AL		 4849
4850 PERL_UNUSED_ARG(debuggable);
79072805 4851
2d03de9c
AL		 4852 if (expr) {
4853 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4854 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4855 expr = newUNOP(OP_DEFINED, 0,
4856 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4857 } else if (expr->op_flags & OPf_KIDS) {
4858 const OP * const k1 = ((UNOP*)expr)->op_first;
4859 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4860 switch (expr->op_type) {
4861 case OP_NULL:
4862 if (k2 && k2->op_type == OP_READLINE
4863 && (k2->op_flags & OPf_STACKED)
4864 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4865 expr = newUNOP(OP_DEFINED, 0, expr);
4866 break;
55d729e4 4867
2d03de9c 4868 case OP_SASSIGN:
72c8de1a 4869 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 4870 || k1->op_type == OP_GLOB
4871 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
72c8de1a 4872 || k1->op_type == OP_EACH))
2d03de9c
AL		 4873 expr = newUNOP(OP_DEFINED, 0, expr);
4874 break;
4875 }
55d729e4 4876 }
748a9306 4877 }
79072805
LW		 4878
4879 if (!block)
4880 block = newOP(OP_NULL, 0);
a034e688 4881 else if (cont || has_my) {
87246558
GS		 4882 block = scope(block);
4883 }
79072805 4884
1ba6ee2b 4885 if (cont) {
79072805 4886 next = LINKLIST(cont);
1ba6ee2b 4887 }
fb73857a 4888 if (expr) {
551405c4 4889 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 4890 if (!next)
4891 next = unstack;
4892 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 4893 }
79072805 4894
ce3e5c45 4895 assert(block);
463ee0b2 4896 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
ce3e5c45 4897 assert(listop);
79072805
LW		 4898 redo = LINKLIST(listop);
4899
4900 if (expr) {
53a7735b 4901 PL_parser->copline = (line_t)whileline;
883ffac3
CS		 4902 scalar(listop);
4903 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 4904 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 4905 op_free(expr); /* oops, it's a while (0) */
463ee0b2 4906 op_free((OP*)loop);
5f66b61c 4907 return NULL; /* listop already freed by new_logop */
463ee0b2 4908 }
883ffac3 4909 if (listop)
497b47a8 4910 ((LISTOP*)listop)->op_last->op_next =
883ffac3 4911 (o == listop ? redo : LINKLIST(o));
79072805
LW		 4912 }
4913 else
11343788 4914 o = listop;
79072805
LW		 4915
4916 if (!loop) {
b7dc083c 4917 NewOp(1101,loop,1,LOOP);
79072805 4918 loop->op_type = OP_ENTERLOOP;
22c35a8c 4919 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 4920 loop->op_private = 0;
4921 loop->op_next = (OP*)loop;
4922 }
4923
11343788 4924 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 4925
4926 loop->op_redoop = redo;
11343788 4927 loop->op_lastop = o;
1ba6ee2b 4928 o->op_private |= loopflags;
79072805
LW		 4929
4930 if (next)
4931 loop->op_nextop = next;
4932 else
11343788 4933 loop->op_nextop = o;
79072805 4934
11343788
MB		 4935 o->op_flags |= flags;
4936 o->op_private |= (flags >> 8);
4937 return o;
79072805
LW		 4938}
4939
4940OP *
66a1b24b 4941Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
79072805 4942{
27da23d5 4943 dVAR;
79072805 4944 LOOP *loop;
fb73857a 4945 OP *wop;
4bbc6d12 4946 PADOFFSET padoff = 0;
4633a7c4 4947 I32 iterflags = 0;
241416b8 4948 I32 iterpflags = 0;
d4c19fe8 4949 OP *madsv = NULL;
79072805 4950
7918f24d
NC		 4951 PERL_ARGS_ASSERT_NEWFOROP;
4952
79072805 4953 if (sv) {
85e6fe83 4954 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 4955 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 4956 sv->op_type = OP_RV2GV;
22c35a8c 4957 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0be9a6bb
RH		 4958
4959 /* The op_type check is needed to prevent a possible segfault
4960 * if the loop variable is undeclared and 'strict vars' is in
4961 * effect. This is illegal but is nonetheless parsed, so we
4962 * may reach this point with an OP_CONST where we're expecting
4963 * an OP_GV.
4964 */
4965 if (cUNOPx(sv)->op_first->op_type == OP_GV
4966 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
0d863452 4967 iterpflags |= OPpITER_DEF;
79072805 4968 }
85e6fe83 4969 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 4970 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 4971 padoff = sv->op_targ;
eb8433b7
NC		 4972 if (PL_madskills)
4973 madsv = sv;
4974 else {
4975 sv->op_targ = 0;
4976 op_free(sv);
4977 }
5f66b61c 4978 sv = NULL;
85e6fe83 4979 }
79072805 4980 else
cea2e8a9 4981 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
f8503592
NC		 4982 if (padoff) {
4983 SV *const namesv = PAD_COMPNAME_SV(padoff);
4984 STRLEN len;
4985 const char *const name = SvPV_const(namesv, len);
4986
4987 if (len == 2 && name[0] == '$' && name[1] == '_')
4988 iterpflags |= OPpITER_DEF;
4989 }
79072805
LW		 4990 }
4991 else {
9f7d9405 4992 const PADOFFSET offset = pad_findmy("$_");
00b1698f 4993 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 4994 sv = newGVOP(OP_GV, 0, PL_defgv);
4995 }
4996 else {
4997 padoff = offset;
aabe9514 4998 }
0d863452 4999 iterpflags |= OPpITER_DEF;
79072805 5000 }
5f05dabc 5001 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 5002 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 5003 iterflags |= OPf_STACKED;
5004 }
89ea2908
GA		 5005 else if (expr->op_type == OP_NULL &&
5006 (expr->op_flags & OPf_KIDS) &&
5007 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5008 {
5009 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5010 * set the STACKED flag to indicate that these values are to be
5011 * treated as min/max values by 'pp_iterinit'.
5012 */
d4c19fe8 5013 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 5014 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 5015 OP* const left = range->op_first;
5016 OP* const right = left->op_sibling;
5152d7c7 5017 LISTOP* listop;
89ea2908
GA		 5018
5019 range->op_flags &= ~OPf_KIDS;
5f66b61c 5020 range->op_first = NULL;
89ea2908 5021
5152d7c7 5022 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 5023 listop->op_first->op_next = range->op_next;
5024 left->op_next = range->op_other;
5152d7c7
GS		 5025 right->op_next = (OP*)listop;
5026 listop->op_next = listop->op_first;
89ea2908 5027
eb8433b7
NC		 5028#ifdef PERL_MAD
5029 op_getmad(expr,(OP*)listop,'O');
5030#else
89ea2908 5031 op_free(expr);
eb8433b7 5032#endif
5152d7c7 5033 expr = (OP*)(listop);
93c66552 5034 op_null(expr);
89ea2908
GA		 5035 iterflags |= OPf_STACKED;
5036 }
5037 else {
5038 expr = mod(force_list(expr), OP_GREPSTART);
5039 }
5040
4633a7c4 5041 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 5042 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 5043 assert(!loop->op_next);
241416b8 5044 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 5045 * for our $x () sets OPpOUR_INTRO */
c5661c80 5046 loop->op_private = (U8)iterpflags;
b7dc083c 5047#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 5048 {
5049 LOOP *tmp;
5050 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 5051 Copy(loop,tmp,1,LISTOP);
bfafaa29 5052 S_op_destroy(aTHX_ (OP*)loop);
155aba94
GS		 5053 loop = tmp;
5054 }
b7dc083c 5055#else
10edeb5d 5056 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
1c846c1f 5057#endif
85e6fe83 5058 loop->op_targ = padoff;
a034e688 5059 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 5060 if (madsv)
5061 op_getmad(madsv, (OP*)loop, 'v');
53a7735b 5062 PL_parser->copline = forline;
fb73857a 5063 return newSTATEOP(0, label, wop);
79072805
LW		 5064}
5065
8990e307 5066OP*
864dbfa3 5067Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 5068{
97aff369 5069 dVAR;
11343788 5070 OP *o;
2d8e6c8d 5071
7918f24d
NC		 5072 PERL_ARGS_ASSERT_NEWLOOPEX;
5073
8990e307 5074 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 5075 /* "last()" means "last" */
5076 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5077 o = newOP(type, OPf_SPECIAL);
5078 else {
ea71c68d 5079 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4ea561bc 5080 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
666ea192 5081 : ""));
cdaebead 5082 }
eb8433b7
NC		 5083#ifdef PERL_MAD
5084 op_getmad(label,o,'L');
5085#else
8990e307 5086 op_free(label);
eb8433b7 5087#endif
8990e307
LW		 5088 }
5089 else {
e3aba57a
RGS		 5090 /* Check whether it's going to be a goto &function */
5091 if (label->op_type == OP_ENTERSUB
5092 && !(label->op_flags & OPf_STACKED))
a0d0e21e 5093 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 5094 o = newUNOP(type, OPf_STACKED, label);
8990e307 5095 }
3280af22 5096 PL_hints |= HINT_BLOCK_SCOPE;
11343788 5097 return o;
8990e307
LW		 5098}
5099
0d863452
RH		 5100/* if the condition is a literal array or hash
5101 (or @{ ... } etc), make a reference to it.
5102 */
5103STATIC OP *
5104S_ref_array_or_hash(pTHX_ OP *cond)
5105{
5106 if (cond
5107 && (cond->op_type == OP_RV2AV
5108 || cond->op_type == OP_PADAV
5109 || cond->op_type == OP_RV2HV
5110 || cond->op_type == OP_PADHV))
5111
5112 return newUNOP(OP_REFGEN,
5113 0, mod(cond, OP_REFGEN));
5114
5115 else
5116 return cond;
5117}
5118
5119/* These construct the optree fragments representing given()
5120 and when() blocks.
5121
5122 entergiven and enterwhen are LOGOPs; the op_other pointer
5123 points up to the associated leave op. We need this so we
5124 can put it in the context and make break/continue work.
5125 (Also, of course, pp_enterwhen will jump straight to
5126 op_other if the match fails.)
5127 */
5128
4136a0f7 5129STATIC OP *
0d863452
RH		 5130S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5131 I32 enter_opcode, I32 leave_opcode,
5132 PADOFFSET entertarg)
5133{
97aff369 5134 dVAR;
0d863452
RH		 5135 LOGOP *enterop;
5136 OP *o;
5137
7918f24d
NC		 5138 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5139
0d863452 5140 NewOp(1101, enterop, 1, LOGOP);
61a59f30 5141 enterop->op_type = (Optype)enter_opcode;
0d863452
RH		 5142 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5143 enterop->op_flags = (U8) OPf_KIDS;
5144 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5145 enterop->op_private = 0;
5146
5147 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5148
5149 if (cond) {
5150 enterop->op_first = scalar(cond);
5151 cond->op_sibling = block;
5152
5153 o->op_next = LINKLIST(cond);
5154 cond->op_next = (OP *) enterop;
5155 }
5156 else {
5157 /* This is a default {} block */
5158 enterop->op_first = block;
5159 enterop->op_flags |= OPf_SPECIAL;
5160
5161 o->op_next = (OP *) enterop;
5162 }
5163
5164 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5165 entergiven and enterwhen both
5166 use ck_null() */
5167
5168 enterop->op_next = LINKLIST(block);
5169 block->op_next = enterop->op_other = o;
5170
5171 return o;
5172}
5173
5174/* Does this look like a boolean operation? For these purposes
5175 a boolean operation is:
5176 - a subroutine call [*]
5177 - a logical connective
5178 - a comparison operator
5179 - a filetest operator, with the exception of -s -M -A -C
5180 - defined(), exists() or eof()
5181 - /$re/ or $foo =~ /$re/
5182
5183 [*] possibly surprising
5184 */
4136a0f7 5185STATIC bool
ef519e13 5186S_looks_like_bool(pTHX_ const OP *o)
0d863452 5187{
97aff369 5188 dVAR;
7918f24d
NC		 5189
5190 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5191
0d863452
RH		 5192 switch(o->op_type) {
5193 case OP_OR:
f92e1a16 5194 case OP_DOR:
0d863452
RH		 5195 return looks_like_bool(cLOGOPo->op_first);
5196
5197 case OP_AND:
5198 return (
5199 looks_like_bool(cLOGOPo->op_first)
5200 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5201
1e1d4b91
JJ		 5202 case OP_NULL:
5203 return (
5204 o->op_flags & OPf_KIDS
5205 && looks_like_bool(cUNOPo->op_first));
5206
0d863452
RH		 5207 case OP_ENTERSUB:
5208
5209 case OP_NOT: case OP_XOR:
0d863452
RH		 5210
5211 case OP_EQ: case OP_NE: case OP_LT:
5212 case OP_GT: case OP_LE: case OP_GE:
5213
5214 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5215 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5216
5217 case OP_SEQ: case OP_SNE: case OP_SLT:
5218 case OP_SGT: case OP_SLE: case OP_SGE:
5219
5220 case OP_SMARTMATCH:
5221
5222 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5223 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5224 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5225 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5226 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5227 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5228 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5229 case OP_FTTEXT: case OP_FTBINARY:
5230
5231 case OP_DEFINED: case OP_EXISTS:
5232 case OP_MATCH: case OP_EOF:
5233
f118ea0d
RGS		 5234 case OP_FLOP:
5235
0d863452
RH		 5236 return TRUE;
5237
5238 case OP_CONST:
5239 /* Detect comparisons that have been optimized away */
5240 if (cSVOPo->op_sv == &PL_sv_yes
5241 || cSVOPo->op_sv == &PL_sv_no)
5242
5243 return TRUE;
6e03d743
RGS		 5244 else
5245 return FALSE;
6e03d743 5246
0d863452
RH		 5247 /* FALL THROUGH */
5248 default:
5249 return FALSE;
5250 }
5251}
5252
5253OP *
5254Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5255{
97aff369 5256 dVAR;
7918f24d 5257 PERL_ARGS_ASSERT_NEWGIVENOP;
0d863452
RH		 5258 return newGIVWHENOP(
5259 ref_array_or_hash(cond),
5260 block,
5261 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5262 defsv_off);
5263}
5264
5265/* If cond is null, this is a default {} block */
5266OP *
5267Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5268{
ef519e13 5269 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 5270 OP *cond_op;
5271
7918f24d
NC		 5272 PERL_ARGS_ASSERT_NEWWHENOP;
5273
0d863452
RH		 5274 if (cond_llb)
5275 cond_op = cond;
5276 else {
5277 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5278 newDEFSVOP(),
5279 scalar(ref_array_or_hash(cond)));
5280 }
5281
5282 return newGIVWHENOP(
5283 cond_op,
5284 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5285 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5286}
5287
7dafbf52
DM		 5288/*
5289=for apidoc cv_undef
5290
5291Clear out all the active components of a CV. This can happen either
5292by an explicit C<undef &foo>, or by the reference count going to zero.
5293In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5294children can still follow the full lexical scope chain.
5295
5296=cut
5297*/
5298
79072805 5299void
864dbfa3 5300Perl_cv_undef(pTHX_ CV *cv)
79072805 5301{
27da23d5 5302 dVAR;
503de470 5303
7918f24d
NC		 5304 PERL_ARGS_ASSERT_CV_UNDEF;
5305
503de470
DM		 5306 DEBUG_X(PerlIO_printf(Perl_debug_log,
5307 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5308 PTR2UV(cv), PTR2UV(PL_comppad))
5309 );
5310
a636914a 5311#ifdef USE_ITHREADS
aed2304a 5312 if (CvFILE(cv) && !CvISXSUB(cv)) {
35f1c1c7 5313 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 5314 Safefree(CvFILE(cv));
a636914a 5315 }
b3123a61 5316 CvFILE(cv) = NULL;
a636914a
RH		 5317#endif
5318
aed2304a 5319 if (!CvISXSUB(cv) && CvROOT(cv)) {
bb172083 5320 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
cea2e8a9 5321 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 5322 ENTER;
a0d0e21e 5323
f3548bdc 5324 PAD_SAVE_SETNULLPAD();
a0d0e21e 5325
282f25c9 5326 op_free(CvROOT(cv));
5f66b61c
AL		 5327 CvROOT(cv) = NULL;
5328 CvSTART(cv) = NULL;
8990e307 5329 LEAVE;
79072805 5330 }
ad64d0ec 5331 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
a0714e2c 5332 CvGV(cv) = NULL;
a3985cdc
DM		 5333
5334 pad_undef(cv);
5335
7dafbf52
DM		 5336 /* remove CvOUTSIDE unless this is an undef rather than a free */
5337 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5338 if (!CvWEAKOUTSIDE(cv))
5339 SvREFCNT_dec(CvOUTSIDE(cv));
601f1833 5340 CvOUTSIDE(cv) = NULL;
7dafbf52 5341 }
beab0874 5342 if (CvCONST(cv)) {
ad64d0ec 5343 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
beab0874
JT		 5344 CvCONST_off(cv);
5345 }
d04ba589 5346 if (CvISXSUB(cv) && CvXSUB(cv)) {
96a5add6 5347 CvXSUB(cv) = NULL;
50762d59 5348 }
7dafbf52
DM		 5349 /* delete all flags except WEAKOUTSIDE */
5350 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 5351}
5352
3fe9a6f1 5353void
cbf82dd0
NC		 5354Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5355 const STRLEN len)
5356{
7918f24d
NC		 5357 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5358
cbf82dd0
NC		 5359 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5360 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5361 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5362 || (p && (len != SvCUR(cv) /* Not the same length. */
5363 || memNE(p, SvPVX_const(cv), len))))
5364 && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 5365 SV* const msg = sv_newmortal();
a0714e2c 5366 SV* name = NULL;
3fe9a6f1 5367
5368 if (gv)
bd61b366 5369 gv_efullname3(name = sv_newmortal(), gv, NULL);
6502358f 5370 sv_setpvs(msg, "Prototype mismatch:");
46fc3d4c 5371 if (name)
be2597df 5372 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
3fe9a6f1 5373 if (SvPOK(cv))
be2597df 5374 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
ebe643b9 5375 else
396482e1
GA		 5376 sv_catpvs(msg, ": none");
5377 sv_catpvs(msg, " vs ");
46fc3d4c 5378 if (p)
cbf82dd0 5379 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
46fc3d4c 5380 else
396482e1 5381 sv_catpvs(msg, "none");
be2597df 5382 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
3fe9a6f1 5383 }
5384}
5385
35f1c1c7
SB		 5386static void const_sv_xsub(pTHX_ CV* cv);
5387
beab0874 5388/*
ccfc67b7
JH		 5389
5390=head1 Optree Manipulation Functions
5391
beab0874
JT		 5392=for apidoc cv_const_sv
5393
5394If C<cv> is a constant sub eligible for inlining. returns the constant
5395value returned by the sub. Otherwise, returns NULL.
5396
5397Constant subs can be created with C<newCONSTSUB> or as described in
5398L<perlsub/"Constant Functions">.
5399
5400=cut
5401*/
760ac839 5402SV *
d45f5b30 5403Perl_cv_const_sv(pTHX_ const CV *const cv)
760ac839 5404{
96a5add6 5405 PERL_UNUSED_CONTEXT;
5069cc75
NC		 5406 if (!cv)
5407 return NULL;
5408 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5409 return NULL;
ad64d0ec 5410 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
fe5e78ed 5411}
760ac839 5412
b5c19bd7
DM		 5413/* op_const_sv: examine an optree to determine whether it's in-lineable.
5414 * Can be called in 3 ways:
5415 *
5416 * !cv
5417 * look for a single OP_CONST with attached value: return the value
5418 *
5419 * cv && CvCLONE(cv) && !CvCONST(cv)
5420 *
5421 * examine the clone prototype, and if contains only a single
5422 * OP_CONST referencing a pad const, or a single PADSV referencing
5423 * an outer lexical, return a non-zero value to indicate the CV is
5424 * a candidate for "constizing" at clone time
5425 *
5426 * cv && CvCONST(cv)
5427 *
5428 * We have just cloned an anon prototype that was marked as a const
5429 * candidiate. Try to grab the current value, and in the case of
5430 * PADSV, ignore it if it has multiple references. Return the value.
5431 */
5432
fe5e78ed 5433SV *
6867be6d 5434Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 5435{
97aff369 5436 dVAR;
a0714e2c 5437 SV *sv = NULL;
fe5e78ed 5438
c631f32b
GG		 5439 if (PL_madskills)
5440 return NULL;
5441
0f79a09d 5442 if (!o)
a0714e2c 5443 return NULL;
1c846c1f
NIS		 5444
5445 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 5446 o = cLISTOPo->op_first->op_sibling;
5447
5448 for (; o; o = o->op_next) {
890ce7af 5449 const OPCODE type = o->op_type;
fe5e78ed 5450
1c846c1f 5451 if (sv && o->op_next == o)
fe5e78ed 5452 return sv;
e576b457
JT		 5453 if (o->op_next != o) {
5454 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5455 continue;
5456 if (type == OP_DBSTATE)
5457 continue;
5458 }
54310121 5459 if (type == OP_LEAVESUB || type == OP_RETURN)
5460 break;
5461 if (sv)
a0714e2c 5462 return NULL;
7766f137 5463 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 5464 sv = cSVOPo->op_sv;
b5c19bd7 5465 else if (cv && type == OP_CONST) {
dd2155a4 5466 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 5467 if (!sv)
a0714e2c 5468 return NULL;
b5c19bd7
DM		 5469 }
5470 else if (cv && type == OP_PADSV) {
5471 if (CvCONST(cv)) { /* newly cloned anon */
5472 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5473 /* the candidate should have 1 ref from this pad and 1 ref
5474 * from the parent */
5475 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 5476 return NULL;
beab0874 5477 sv = newSVsv(sv);
b5c19bd7
DM		 5478 SvREADONLY_on(sv);
5479 return sv;
5480 }
5481 else {
5482 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5483 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 5484 }
760ac839 5485 }
b5c19bd7 5486 else {
a0714e2c 5487 return NULL;
b5c19bd7 5488 }
760ac839
LW		 5489 }
5490 return sv;
5491}
5492
eb8433b7
NC		 5493#ifdef PERL_MAD
5494OP *
5495#else
09bef843 5496void
eb8433b7 5497#endif
09bef843
SB		 5498Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5499{
99129197
NC		 5500#if 0
5501 /* This would be the return value, but the return cannot be reached. */
eb8433b7
NC		 5502 OP* pegop = newOP(OP_NULL, 0);
5503#endif
5504
46c461b5
AL		 5505 PERL_UNUSED_ARG(floor);
5506
09bef843
SB		 5507 if (o)
5508 SAVEFREEOP(o);
5509 if (proto)
5510 SAVEFREEOP(proto);
5511 if (attrs)
5512 SAVEFREEOP(attrs);
5513 if (block)
5514 SAVEFREEOP(block);
5515 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
eb8433b7 5516#ifdef PERL_MAD
99129197 5517 NORETURN_FUNCTION_END;
eb8433b7 5518#endif
09bef843
SB		 5519}
5520
748a9306 5521CV *
864dbfa3 5522Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 5523{
5f66b61c 5524 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
09bef843
SB		 5525}
5526
5527CV *
5528Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5529{
27da23d5 5530 dVAR;
83ee9e09 5531 GV *gv;
5c144d81 5532 const char *ps;
ea6e9374 5533 STRLEN ps_len;
c445ea15 5534 register CV *cv = NULL;
beab0874 5535 SV *const_sv;
b48b272a
NC		 5536 /* If the subroutine has no body, no attributes, and no builtin attributes
5537 then it's just a sub declaration, and we may be able to get away with
5538 storing with a placeholder scalar in the symbol table, rather than a
5539 full GV and CV. If anything is present then it will take a full CV to
5540 store it. */
5541 const I32 gv_fetch_flags
eb8433b7
NC		 5542 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5543 || PL_madskills)
b48b272a 5544 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4ea561bc 5545 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
ed4a8a9b 5546 bool has_name;
8e742a20
MHM		 5547
5548 if (proto) {
5549 assert(proto->op_type == OP_CONST);
4ea561bc 5550 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8e742a20
MHM		 5551 }
5552 else
bd61b366 5553 ps = NULL;
8e742a20 5554
ed4a8a9b
NC		 5555 if (name) {
5556 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5557 has_name = TRUE;
5558 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 5559 SV * const sv = sv_newmortal();
c99da370
JH		 5560 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5561 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 5562 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
ed4a8a9b
NC		 5563 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5564 has_name = TRUE;
c1754fce
NC		 5565 } else if (PL_curstash) {
5566 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 5567 has_name = FALSE;
c1754fce
NC		 5568 } else {
5569 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
ed4a8a9b 5570 has_name = FALSE;
c1754fce 5571 }
83ee9e09 5572
eb8433b7
NC		 5573 if (!PL_madskills) {
5574 if (o)
5575 SAVEFREEOP(o);
5576 if (proto)
5577 SAVEFREEOP(proto);
5578 if (attrs)
5579 SAVEFREEOP(attrs);
5580 }
3fe9a6f1 5581
09bef843 5582 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 5583 maximum a prototype before. */
5584 if (SvTYPE(gv) > SVt_NULL) {
ad64d0ec
NC		 5585 if (!SvPOK((const SV *)gv)
5586 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
e476b1b5 5587 && ckWARN_d(WARN_PROTOTYPE))
f248d071 5588 {
9014280d 5589 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 5590 }
ea726b52 5591 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
55d729e4
GS		 5592 }
5593 if (ps)
ad64d0ec 5594 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
55d729e4 5595 else
ad64d0ec 5596 sv_setiv(MUTABLE_SV(gv), -1);
e1a479c5 5597
3280af22
NIS		 5598 SvREFCNT_dec(PL_compcv);
5599 cv = PL_compcv = NULL;
beab0874 5600 goto done;
55d729e4
GS		 5601 }
5602
601f1833 5603 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 5604
eb8433b7
NC		 5605 if (!block || !ps || *ps || attrs
5606 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5607#ifdef PERL_MAD
5608 || block->op_type == OP_NULL
5609#endif
5610 )
a0714e2c 5611 const_sv = NULL;
beab0874 5612 else
601f1833 5613 const_sv = op_const_sv(block, NULL);
beab0874
JT		 5614
5615 if (cv) {
6867be6d 5616 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 5617
60ed1d8c
GS		 5618 /* if the subroutine doesn't exist and wasn't pre-declared
5619 * with a prototype, assume it will be AUTOLOADed,
5620 * skipping the prototype check
5621 */
5622 if (exists || SvPOK(cv))
cbf82dd0 5623 cv_ckproto_len(cv, gv, ps, ps_len);
68dc0745 5624 /* already defined (or promised)? */
60ed1d8c 5625 if (exists || GvASSUMECV(gv)) {
eb8433b7
NC		 5626 if ((!block
5627#ifdef PERL_MAD
5628 || block->op_type == OP_NULL
5629#endif
5630 )&& !attrs) {
d3cea301
SB		 5631 if (CvFLAGS(PL_compcv)) {
5632 /* might have had built-in attrs applied */
5633 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5634 }
aa689395 5635 /* just a "sub foo;" when &foo is already defined */
3280af22 5636 SAVEFREESV(PL_compcv);
aa689395 5637 goto done;
5638 }
eb8433b7
NC		 5639 if (block
5640#ifdef PERL_MAD
5641 && block->op_type != OP_NULL
5642#endif
5643 ) {
beab0874
JT		 5644 if (ckWARN(WARN_REDEFINE)
5645 || (CvCONST(cv)
5646 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5647 {
6867be6d 5648 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 5649 if (PL_parser && PL_parser->copline != NOLINE)
5650 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 5651 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 5652 CvCONST(cv) ? "Constant subroutine %s redefined"
5653 : "Subroutine %s redefined", name);
beab0874
JT		 5654 CopLINE_set(PL_curcop, oldline);
5655 }
eb8433b7
NC		 5656#ifdef PERL_MAD
5657 if (!PL_minus_c) /* keep old one around for madskills */
5658#endif
5659 {
5660 /* (PL_madskills unset in used file.) */
5661 SvREFCNT_dec(cv);
5662 }
601f1833 5663 cv = NULL;
79072805 5664 }
79072805
LW		 5665 }
5666 }
beab0874 5667 if (const_sv) {
f84c484e 5668 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 5669 if (cv) {
0768512c 5670 assert(!CvROOT(cv) && !CvCONST(cv));
ad64d0ec 5671 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
beab0874
JT		 5672 CvXSUBANY(cv).any_ptr = const_sv;
5673 CvXSUB(cv) = const_sv_xsub;
5674 CvCONST_on(cv);
d04ba589 5675 CvISXSUB_on(cv);
beab0874
JT		 5676 }
5677 else {
601f1833 5678 GvCV(gv) = NULL;
beab0874
JT		 5679 cv = newCONSTSUB(NULL, name, const_sv);
5680 }
e1a479c5
BB		 5681 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5682 (CvGV(cv) && GvSTASH(CvGV(cv)))
5683 ? GvSTASH(CvGV(cv))
5684 : CvSTASH(cv)
5685 ? CvSTASH(cv)
5686 : PL_curstash
5687 );
eb8433b7
NC		 5688 if (PL_madskills)
5689 goto install_block;
beab0874
JT		 5690 op_free(block);
5691 SvREFCNT_dec(PL_compcv);
5692 PL_compcv = NULL;
beab0874
JT		 5693 goto done;
5694 }
09bef843
SB		 5695 if (attrs) {
5696 HV *stash;
5697 SV *rcv;
5698
5699 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5700 * before we clobber PL_compcv.
5701 */
99129197 5702 if (cv && (!block
eb8433b7
NC		 5703#ifdef PERL_MAD
5704 || block->op_type == OP_NULL
5705#endif
5706 )) {
ad64d0ec 5707 rcv = MUTABLE_SV(cv);
020f0e03
SB		 5708 /* Might have had built-in attributes applied -- propagate them. */
5709 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 5710 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 5711 stash = GvSTASH(CvGV(cv));
a9164de8 5712 else if (CvSTASH(cv))
09bef843
SB		 5713 stash = CvSTASH(cv);
5714 else
5715 stash = PL_curstash;
5716 }
5717 else {
5718 /* possibly about to re-define existing subr -- ignore old cv */
ad64d0ec 5719 rcv = MUTABLE_SV(PL_compcv);
a9164de8 5720 if (name && GvSTASH(gv))
09bef843
SB		 5721 stash = GvSTASH(gv);
5722 else
5723 stash = PL_curstash;
5724 }
95f0a2f1 5725 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 5726 }
a0d0e21e 5727 if (cv) { /* must reuse cv if autoloaded */
eb8433b7
NC		 5728 if (
5729#ifdef PERL_MAD
5730 (
5731#endif
5732 !block
5733#ifdef PERL_MAD
5734 || block->op_type == OP_NULL) && !PL_madskills
5735#endif
5736 ) {
09bef843
SB		 5737 /* got here with just attrs -- work done, so bug out */
5738 SAVEFREESV(PL_compcv);
5739 goto done;
5740 }
a3985cdc 5741 /* transfer PL_compcv to cv */
4633a7c4 5742 cv_undef(cv);
3280af22 5743 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5c41a5fa
DM		 5744 if (!CvWEAKOUTSIDE(cv))
5745 SvREFCNT_dec(CvOUTSIDE(cv));
3280af22 5746 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 5747 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 5748 CvOUTSIDE(PL_compcv) = 0;
5749 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5750 CvPADLIST(PL_compcv) = 0;
282f25c9 5751 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 5752 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 5753 /* ... before we throw it away */
3280af22 5754 SvREFCNT_dec(PL_compcv);
b5c19bd7 5755 PL_compcv = cv;
a933f601
IZ		 5756 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5757 ++PL_sub_generation;
a0d0e21e
LW		 5758 }
5759 else {
3280af22 5760 cv = PL_compcv;
44a8e56a 5761 if (name) {
5762 GvCV(gv) = cv;
eb8433b7
NC		 5763 if (PL_madskills) {
5764 if (strEQ(name, "import")) {
ad64d0ec 5765 PL_formfeed = MUTABLE_SV(cv);
eb8433b7
NC		 5766 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5767 }
5768 }
44a8e56a 5769 GvCVGEN(gv) = 0;
e1a479c5 5770 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
44a8e56a 5771 }
a0d0e21e 5772 }
65c50114 5773 CvGV(cv) = gv;
a636914a 5774 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 5775 CvSTASH(cv) = PL_curstash;
8990e307 5776
3fe9a6f1 5777 if (ps)
ad64d0ec 5778 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
4633a7c4 5779
13765c85 5780 if (PL_parser && PL_parser->error_count) {
c07a80fd 5781 op_free(block);
5f66b61c 5782 block = NULL;
68dc0745 5783 if (name) {
6867be6d 5784 const char *s = strrchr(name, ':');
68dc0745 5785 s = s ? s+1 : name;
6d4c2119 5786 if (strEQ(s, "BEGIN")) {
e1ec3a88 5787 const char not_safe[] =
6d4c2119 5788 "BEGIN not safe after errors--compilation aborted";
faef0170 5789 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 5790 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 5791 else {
5792 /* force display of errors found but not reported */
38a03e6e 5793 sv_catpv(ERRSV, not_safe);
be2597df 5794 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6d4c2119
CS		 5795 }
5796 }
68dc0745 5797 }
c07a80fd 5798 }
eb8433b7 5799 install_block:
beab0874
JT		 5800 if (!block)
5801 goto done;
a0d0e21e 5802
aac018bb
NC		 5803 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5804 the debugger could be able to set a breakpoint in, so signal to
5805 pp_entereval that it should not throw away any saved lines at scope
5806 exit. */
5807
fd06b02c 5808 PL_breakable_sub_gen++;
7766f137 5809 if (CvLVALUE(cv)) {
78f9721b
SM		 5810 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5811 mod(scalarseq(block), OP_LEAVESUBLV));
7e5d8ed2 5812 block->op_attached = 1;
7766f137
GS		 5813 }
5814 else {
09c2fd24
AE		 5815 /* This makes sub {}; work as expected. */
5816 if (block->op_type == OP_STUB) {
1496a290 5817 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 5818#ifdef PERL_MAD
5819 op_getmad(block,newblock,'B');
5820#else
09c2fd24 5821 op_free(block);
eb8433b7
NC		 5822#endif
5823 block = newblock;
09c2fd24 5824 }
7e5d8ed2
DM		 5825 else
5826 block->op_attached = 1;
7766f137
GS		 5827 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5828 }
5829 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5830 OpREFCNT_set(CvROOT(cv), 1);
5831 CvSTART(cv) = LINKLIST(CvROOT(cv));
5832 CvROOT(cv)->op_next = 0;
a2efc822 5833 CALL_PEEP(CvSTART(cv));
7766f137
GS		 5834
5835 /* now that optimizer has done its work, adjust pad values */
54310121 5836
dd2155a4
DM		 5837 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5838
5839 if (CvCLONE(cv)) {
beab0874
JT		 5840 assert(!CvCONST(cv));
5841 if (ps && !*ps && op_const_sv(block, cv))
5842 CvCONST_on(cv);
a0d0e21e 5843 }
79072805 5844
ed4a8a9b 5845 if (has_name) {
3280af22 5846 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
561b68a9 5847 SV * const sv = newSV(0);
c4420975 5848 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 5849 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5850 GV_ADDMULTI, SVt_PVHV);
44a8e56a 5851 HV *hv;
5852
ed094faf
GS		 5853 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5854 CopFILE(PL_curcop),
cc49e20b 5855 (long)PL_subline, (long)CopLINE(PL_curcop));
bd61b366 5856 gv_efullname3(tmpstr, gv, NULL);
04fe65b0
RGS		 5857 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5858 SvCUR(tmpstr), sv, 0);
44a8e56a 5859 hv = GvHVn(db_postponed);
551405c4
AL		 5860 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5861 CV * const pcv = GvCV(db_postponed);
5862 if (pcv) {
5863 dSP;
5864 PUSHMARK(SP);
5865 XPUSHs(tmpstr);
5866 PUTBACK;
ad64d0ec 5867 call_sv(MUTABLE_SV(pcv), G_DISCARD);
551405c4 5868 }
44a8e56a 5869 }
5870 }
79072805 5871
13765c85 5872 if (name && ! (PL_parser && PL_parser->error_count))
0cd10f52 5873 process_special_blocks(name, gv, cv);
33fb7a6e 5874 }
ed094faf 5875
33fb7a6e 5876 done:
53a7735b
DM		 5877 if (PL_parser)
5878 PL_parser->copline = NOLINE;
33fb7a6e
NC		 5879 LEAVE_SCOPE(floor);
5880 return cv;
5881}
ed094faf 5882
33fb7a6e
NC		 5883STATIC void
5884S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5885 CV *const cv)
5886{
5887 const char *const colon = strrchr(fullname,':');
5888 const char *const name = colon ? colon + 1 : fullname;
5889
7918f24d
NC		 5890 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5891
33fb7a6e 5892 if (*name == 'B') {
6952d67e 5893 if (strEQ(name, "BEGIN")) {
6867be6d 5894 const I32 oldscope = PL_scopestack_ix;
28757baa 5895 ENTER;
57843af0
GS		 5896 SAVECOPFILE(&PL_compiling);
5897 SAVECOPLINE(&PL_compiling);
28757baa 5898
cc8773c0 5899 DEBUG_B( dump_sub(gv) );
ad64d0ec 5900 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
ea2f84a3 5901 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 5902 call_list(oldscope, PL_beginav);
a6006777 5903
3280af22 5904 PL_curcop = &PL_compiling;
623e6609 5905 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 5906 LEAVE;
5907 }
33fb7a6e
NC		 5908 else
5909 return;
5910 } else {
5911 if (*name == 'E') {
5912 if strEQ(name, "END") {
cc8773c0 5913 DEBUG_B( dump_sub(gv) );
ad64d0ec 5914 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
33fb7a6e
NC		 5915 } else
5916 return;
5917 } else if (*name == 'U') {
5918 if (strEQ(name, "UNITCHECK")) {
5919 /* It's never too late to run a unitcheck block */
ad64d0ec 5920 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
33fb7a6e
NC		 5921 }
5922 else
5923 return;
5924 } else if (*name == 'C') {
5925 if (strEQ(name, "CHECK")) {
5926 if (PL_main_start && ckWARN(WARN_VOID))
5927 Perl_warner(aTHX_ packWARN(WARN_VOID),
5928 "Too late to run CHECK block");
ad64d0ec 5929 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
33fb7a6e
NC		 5930 }
5931 else
5932 return;
5933 } else if (*name == 'I') {
5934 if (strEQ(name, "INIT")) {
5935 if (PL_main_start && ckWARN(WARN_VOID))
5936 Perl_warner(aTHX_ packWARN(WARN_VOID),
5937 "Too late to run INIT block");
ad64d0ec 5938 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
33fb7a6e
NC		 5939 }
5940 else
5941 return;
5942 } else
5943 return;
cc8773c0 5944 DEBUG_B( dump_sub(gv) );
33fb7a6e 5945 GvCV(gv) = 0; /* cv has been hijacked */
79072805 5946 }
79072805
LW		 5947}
5948
954c1994
GS		 5949/*
5950=for apidoc newCONSTSUB
5951
5952Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5953eligible for inlining at compile-time.
5954
99ab892b
NC		 5955Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5956which won't be called if used as a destructor, but will suppress the overhead
5957of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5958compile time.)
5959
954c1994
GS		 5960=cut
5961*/
5962
beab0874 5963CV *
e1ec3a88 5964Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5476c433 5965{
27da23d5 5966 dVAR;
beab0874 5967 CV* cv;
cbf82dd0 5968#ifdef USE_ITHREADS
54d012c6 5969 const char *const file = CopFILE(PL_curcop);
cbf82dd0
NC		 5970#else
5971 SV *const temp_sv = CopFILESV(PL_curcop);
def18e4c 5972 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
cbf82dd0 5973#endif
5476c433 5974
11faa288 5975 ENTER;
11faa288 5976
401667e9
DM		 5977 if (IN_PERL_RUNTIME) {
5978 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5979 * an op shared between threads. Use a non-shared COP for our
5980 * dirty work */
5981 SAVEVPTR(PL_curcop);
5982 PL_curcop = &PL_compiling;
5983 }
f4dd75d9 5984 SAVECOPLINE(PL_curcop);
53a7735b 5985 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
f4dd75d9
GS		 5986
5987 SAVEHINTS();
3280af22 5988 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 5989
5990 if (stash) {
5991 SAVESPTR(PL_curstash);
5992 SAVECOPSTASH(PL_curcop);
5993 PL_curstash = stash;
05ec9bb3 5994 CopSTASH_set(PL_curcop,stash);
11faa288 5995 }
5476c433 5996
cbf82dd0
NC		 5997 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5998 and so doesn't get free()d. (It's expected to be from the C pre-
5999 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee 6000 and we need it to get freed. */
54d012c6
NC		 6001 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6002 XS_DYNAMIC_FILENAME);
beab0874
JT		 6003 CvXSUBANY(cv).any_ptr = sv;
6004 CvCONST_on(cv);
5476c433 6005
65e66c80 6006#ifdef USE_ITHREADS
02f28d44
MHM		 6007 if (stash)
6008 CopSTASH_free(PL_curcop);
65e66c80 6009#endif
11faa288 6010 LEAVE;
beab0874
JT		 6011
6012 return cv;
5476c433
JD		 6013}
6014
77004dee
NC		 6015CV *
6016Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6017 const char *const filename, const char *const proto,
6018 U32 flags)
6019{
6020 CV *cv = newXS(name, subaddr, filename);
6021
7918f24d
NC		 6022 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6023
77004dee
NC		 6024 if (flags & XS_DYNAMIC_FILENAME) {
6025 /* We need to "make arrangements" (ie cheat) to ensure that the
6026 filename lasts as long as the PVCV we just created, but also doesn't
6027 leak */
6028 STRLEN filename_len = strlen(filename);
6029 STRLEN proto_and_file_len = filename_len;
6030 char *proto_and_file;
6031 STRLEN proto_len;
6032
6033 if (proto) {
6034 proto_len = strlen(proto);
6035 proto_and_file_len += proto_len;
6036
6037 Newx(proto_and_file, proto_and_file_len + 1, char);
6038 Copy(proto, proto_and_file, proto_len, char);
6039 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6040 } else {
6041 proto_len = 0;
6042 proto_and_file = savepvn(filename, filename_len);
6043 }
6044
6045 /* This gets free()d. :-) */
ad64d0ec 6046 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
77004dee
NC		 6047 SV_HAS_TRAILING_NUL);
6048 if (proto) {
6049 /* This gives us the correct prototype, rather than one with the
6050 file name appended. */
6051 SvCUR_set(cv, proto_len);
6052 } else {
6053 SvPOK_off(cv);
6054 }
81a2b3b6 6055 CvFILE(cv) = proto_and_file + proto_len;
77004dee 6056 } else {
ad64d0ec 6057 sv_setpv(MUTABLE_SV(cv), proto);
77004dee
NC		 6058 }
6059 return cv;
6060}
6061
954c1994
GS		 6062/*
6063=for apidoc U||newXS
6064
77004dee
NC		 6065Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6066static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 6067
6068=cut
6069*/
6070
57d3b86d 6071CV *
bfed75c6 6072Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 6073{
97aff369 6074 dVAR;
666ea192
JH		 6075 GV * const gv = gv_fetchpv(name ? name :
6076 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6077 GV_ADDMULTI, SVt_PVCV);
79072805 6078 register CV *cv;
44a8e56a 6079
7918f24d
NC		 6080 PERL_ARGS_ASSERT_NEWXS;
6081
1ecdd9a8
HS		 6082 if (!subaddr)
6083 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6084
601f1833 6085 if ((cv = (name ? GvCV(gv) : NULL))) {
44a8e56a 6086 if (GvCVGEN(gv)) {
6087 /* just a cached method */
6088 SvREFCNT_dec(cv);
601f1833 6089 cv = NULL;
44a8e56a 6090 }
6091 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6092 /* already defined (or promised) */
1df70142 6093 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
66a1b24b
AL		 6094 if (ckWARN(WARN_REDEFINE)) {
6095 GV * const gvcv = CvGV(cv);
6096 if (gvcv) {
6097 HV * const stash = GvSTASH(gvcv);
6098 if (stash) {
8b38226b
AL		 6099 const char *redefined_name = HvNAME_get(stash);
6100 if ( strEQ(redefined_name,"autouse") ) {
66a1b24b 6101 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 6102 if (PL_parser && PL_parser->copline != NOLINE)
6103 CopLINE_set(PL_curcop, PL_parser->copline);
66a1b24b 6104 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 6105 CvCONST(cv) ? "Constant subroutine %s redefined"
6106 : "Subroutine %s redefined"
6107 ,name);
66a1b24b
AL		 6108 CopLINE_set(PL_curcop, oldline);
6109 }
6110 }
6111 }
a0d0e21e
LW		 6112 }
6113 SvREFCNT_dec(cv);
601f1833 6114 cv = NULL;
79072805 6115 }
79072805 6116 }
44a8e56a 6117
6118 if (cv) /* must reuse cv if autoloaded */
6119 cv_undef(cv);
a0d0e21e 6120 else {
ea726b52 6121 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
44a8e56a 6122 if (name) {
6123 GvCV(gv) = cv;
6124 GvCVGEN(gv) = 0;
e1a479c5 6125 mro_method_changed_in(GvSTASH(gv)); /* newXS */
44a8e56a 6126 }
a0d0e21e 6127 }
65c50114 6128 CvGV(cv) = gv;
b195d487 6129 (void)gv_fetchfile(filename);
dd374669 6130 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 6131 an external constant string */
d04ba589 6132 CvISXSUB_on(cv);
a0d0e21e 6133 CvXSUB(cv) = subaddr;
44a8e56a 6134
33fb7a6e
NC		 6135 if (name)
6136 process_special_blocks(name, gv, cv);
8990e307 6137 else
a5f75d66 6138 CvANON_on(cv);
44a8e56a 6139
a0d0e21e 6140 return cv;
79072805
LW		 6141}
6142
eb8433b7
NC		 6143#ifdef PERL_MAD
6144OP *
6145#else
79072805 6146void
eb8433b7 6147#endif
864dbfa3 6148Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 6149{
97aff369 6150 dVAR;
79072805 6151 register CV *cv;
eb8433b7
NC		 6152#ifdef PERL_MAD
6153 OP* pegop = newOP(OP_NULL, 0);
6154#endif
79072805 6155
0bd48802 6156 GV * const gv = o
f776e3cd 6157 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 6158 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 6159
a5f75d66 6160 GvMULTI_on(gv);
155aba94 6161 if ((cv = GvFORM(gv))) {
599cee73 6162 if (ckWARN(WARN_REDEFINE)) {
6867be6d 6163 const line_t oldline = CopLINE(PL_curcop);
53a7735b
DM		 6164 if (PL_parser && PL_parser->copline != NOLINE)
6165 CopLINE_set(PL_curcop, PL_parser->copline);
ee6d2783
NC		 6166 if (o) {
6167 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6168 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6169 } else {
6170 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6171 "Format STDOUT redefined");
6172 }
57843af0 6173 CopLINE_set(PL_curcop, oldline);
79072805 6174 }
8990e307 6175 SvREFCNT_dec(cv);
79072805 6176 }
3280af22 6177 cv = PL_compcv;
79072805 6178 GvFORM(gv) = cv;
65c50114 6179 CvGV(cv) = gv;
a636914a 6180 CvFILE_set_from_cop(cv, PL_curcop);
79072805 6181
a0d0e21e 6182
dd2155a4 6183 pad_tidy(padtidy_FORMAT);
79072805 6184 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 6185 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6186 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 6187 CvSTART(cv) = LINKLIST(CvROOT(cv));
6188 CvROOT(cv)->op_next = 0;
a2efc822 6189 CALL_PEEP(CvSTART(cv));
eb8433b7
NC		 6190#ifdef PERL_MAD
6191 op_getmad(o,pegop,'n');
6192 op_getmad_weak(block, pegop, 'b');
6193#else
11343788 6194 op_free(o);
eb8433b7 6195#endif
53a7735b
DM		 6196 if (PL_parser)
6197 PL_parser->copline = NOLINE;
8990e307 6198 LEAVE_SCOPE(floor);
eb8433b7
NC		 6199#ifdef PERL_MAD
6200 return pegop;
6201#endif
79072805
LW		 6202}
6203
6204OP *
864dbfa3 6205Perl_newANONLIST(pTHX_ OP *o)
79072805 6206{
78c72037 6207 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 6208}
6209
6210OP *
864dbfa3 6211Perl_newANONHASH(pTHX_ OP *o)
79072805 6212{
78c72037 6213 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 6214}
6215
6216OP *
864dbfa3 6217Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 6218{
5f66b61c 6219 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 6220}
6221
6222OP *
6223Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6224{
a0d0e21e 6225 return newUNOP(OP_REFGEN, 0,
09bef843 6226 newSVOP(OP_ANONCODE, 0,
ad64d0ec 6227 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
79072805
LW		 6228}
6229
6230OP *
864dbfa3 6231Perl_oopsAV(pTHX_ OP *o)
79072805 6232{
27da23d5 6233 dVAR;
7918f24d
NC		 6234
6235 PERL_ARGS_ASSERT_OOPSAV;
6236
ed6116ce
LW		 6237 switch (o->op_type) {
6238 case OP_PADSV:
6239 o->op_type = OP_PADAV;
22c35a8c 6240 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 6241 return ref(o, OP_RV2AV);
b2ffa427 6242
ed6116ce 6243 case OP_RV2SV:
79072805 6244 o->op_type = OP_RV2AV;
22c35a8c 6245 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 6246 ref(o, OP_RV2AV);
ed6116ce
LW		 6247 break;
6248
6249 default:
0453d815 6250 if (ckWARN_d(WARN_INTERNAL))
9014280d 6251 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 6252 break;
6253 }
79072805
LW		 6254 return o;
6255}
6256
6257OP *
864dbfa3 6258Perl_oopsHV(pTHX_ OP *o)
79072805 6259{
27da23d5 6260 dVAR;
7918f24d
NC		 6261
6262 PERL_ARGS_ASSERT_OOPSHV;
6263
ed6116ce
LW		 6264 switch (o->op_type) {
6265 case OP_PADSV:
6266 case OP_PADAV:
6267 o->op_type = OP_PADHV;
22c35a8c 6268 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 6269 return ref(o, OP_RV2HV);
ed6116ce
LW		 6270
6271 case OP_RV2SV:
6272 case OP_RV2AV:
79072805 6273 o->op_type = OP_RV2HV;
22c35a8c 6274 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 6275 ref(o, OP_RV2HV);
ed6116ce
LW		 6276 break;
6277
6278 default:
0453d815 6279 if (ckWARN_d(WARN_INTERNAL))
9014280d 6280 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 6281 break;
6282 }
79072805
LW		 6283 return o;
6284}
6285
6286OP *
864dbfa3 6287Perl_newAVREF(pTHX_ OP *o)
79072805 6288{
27da23d5 6289 dVAR;
7918f24d
NC		 6290
6291 PERL_ARGS_ASSERT_NEWAVREF;
6292
ed6116ce
LW		 6293 if (o->op_type == OP_PADANY) {
6294 o->op_type = OP_PADAV;
22c35a8c 6295 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 6296 return o;
ed6116ce 6297 }
a1063b2d 6298 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 6299 && ckWARN(WARN_DEPRECATED)) {
6300 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 6301 "Using an array as a reference is deprecated");
6302 }
79072805
LW		 6303 return newUNOP(OP_RV2AV, 0, scalar(o));
6304}
6305
6306OP *
864dbfa3 6307Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 6308{
82092f1d 6309 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 6310 return newUNOP(OP_NULL, 0, o);
748a9306 6311 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 6312}
6313
6314OP *
864dbfa3 6315Perl_newHVREF(pTHX_ OP *o)
79072805 6316{
27da23d5 6317 dVAR;
7918f24d
NC		 6318
6319 PERL_ARGS_ASSERT_NEWHVREF;
6320
ed6116ce
LW		 6321 if (o->op_type == OP_PADANY) {
6322 o->op_type = OP_PADHV;
22c35a8c 6323 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 6324 return o;
ed6116ce 6325 }
a1063b2d 6326 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 6327 && ckWARN(WARN_DEPRECATED)) {
6328 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 6329 "Using a hash as a reference is deprecated");
6330 }
79072805
LW		 6331 return newUNOP(OP_RV2HV, 0, scalar(o));
6332}
6333
6334OP *
864dbfa3 6335Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 6336{
c07a80fd 6337 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 6338}
6339
6340OP *
864dbfa3 6341Perl_newSVREF(pTHX_ OP *o)
79072805 6342{
27da23d5 6343 dVAR;
7918f24d
NC		 6344
6345 PERL_ARGS_ASSERT_NEWSVREF;
6346
ed6116ce
LW		 6347 if (o->op_type == OP_PADANY) {
6348 o->op_type = OP_PADSV;
22c35a8c 6349 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 6350 return o;
ed6116ce 6351 }
79072805
LW		 6352 return newUNOP(OP_RV2SV, 0, scalar(o));
6353}
6354
61b743bb
DM		 6355/* Check routines. See the comments at the top of this file for details
6356 * on when these are called */
79072805
LW		 6357
6358OP *
cea2e8a9 6359Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 6360{
7918f24d
NC		 6361 PERL_ARGS_ASSERT_CK_ANONCODE;
6362
dd2155a4 6363 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
eb8433b7 6364 if (!PL_madskills)
1d866c12 6365 cSVOPo->op_sv = NULL;
5dc0d613 6366 return o;
5f05dabc 6367}
6368
6369OP *
cea2e8a9 6370Perl_ck_bitop(pTHX_ OP *o)
55497cff 6371{
97aff369 6372 dVAR;
7918f24d
NC		 6373
6374 PERL_ARGS_ASSERT_CK_BITOP;
6375
276b2a0c
RGS		 6376#define OP_IS_NUMCOMPARE(op) \
6377 ((op) == OP_LT || (op) == OP_I_LT || \
6378 (op) == OP_GT || (op) == OP_I_GT || \
6379 (op) == OP_LE || (op) == OP_I_LE || \
6380 (op) == OP_GE || (op) == OP_I_GE || \
6381 (op) == OP_EQ || (op) == OP_I_EQ || \
6382 (op) == OP_NE || (op) == OP_I_NE || \
6383 (op) == OP_NCMP || (op) == OP_I_NCMP)
d5ec2987 6384 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 6385 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6386 && (o->op_type == OP_BIT_OR
6387 || o->op_type == OP_BIT_AND
6388 || o->op_type == OP_BIT_XOR))
276b2a0c 6389 {
1df70142
AL		 6390 const OP * const left = cBINOPo->op_first;
6391 const OP * const right = left->op_sibling;
96a925ab
YST		 6392 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6393 (left->op_flags & OPf_PARENS) == 0) ||
6394 (OP_IS_NUMCOMPARE(right->op_type) &&
6395 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 6396 if (ckWARN(WARN_PRECEDENCE))
6397 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6398 "Possible precedence problem on bitwise %c operator",
6399 o->op_type == OP_BIT_OR ? '|'
6400 : o->op_type == OP_BIT_AND ? '&' : '^'
6401 );
6402 }
5dc0d613 6403 return o;
55497cff 6404}
6405
6406OP *
cea2e8a9 6407Perl_ck_concat(pTHX_ OP *o)
79072805 6408{
0bd48802 6409 const OP * const kid = cUNOPo->op_first;
7918f24d
NC		 6410
6411 PERL_ARGS_ASSERT_CK_CONCAT;
96a5add6 6412 PERL_UNUSED_CONTEXT;
7918f24d 6413
df91b2c5
AE		 6414 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6415 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 6416 o->op_flags |= OPf_STACKED;
11343788 6417 return o;
79072805
LW		 6418}
6419
6420OP *
cea2e8a9 6421Perl_ck_spair(pTHX_ OP *o)
79072805 6422{
27da23d5 6423 dVAR;
7918f24d
NC		 6424
6425 PERL_ARGS_ASSERT_CK_SPAIR;
6426
11343788 6427 if (o->op_flags & OPf_KIDS) {
79072805 6428 OP* newop;
a0d0e21e 6429 OP* kid;
6867be6d 6430 const OPCODE type = o->op_type;
5dc0d613 6431 o = modkids(ck_fun(o), type);
11343788 6432 kid = cUNOPo->op_first;
a0d0e21e 6433 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 6434 if (newop) {
6435 const OPCODE type = newop->op_type;
6436 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6437 type == OP_PADAV || type == OP_PADHV ||
6438 type == OP_RV2AV || type == OP_RV2HV)
6439 return o;
a0d0e21e 6440 }
eb8433b7
NC		 6441#ifdef PERL_MAD
6442 op_getmad(kUNOP->op_first,newop,'K');
6443#else
a0d0e21e 6444 op_free(kUNOP->op_first);
eb8433b7 6445#endif
a0d0e21e
LW		 6446 kUNOP->op_first = newop;
6447 }
22c35a8c 6448 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 6449 return ck_fun(o);
a0d0e21e
LW		 6450}
6451
6452OP *
cea2e8a9 6453Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 6454{
7918f24d
NC		 6455 PERL_ARGS_ASSERT_CK_DELETE;
6456
11343788 6457 o = ck_fun(o);
5dc0d613 6458 o->op_private = 0;
11343788 6459 if (o->op_flags & OPf_KIDS) {
551405c4 6460 OP * const kid = cUNOPo->op_first;
01020589
GS		 6461 switch (kid->op_type) {
6462 case OP_ASLICE:
6463 o->op_flags |= OPf_SPECIAL;
6464 /* FALL THROUGH */
6465 case OP_HSLICE:
5dc0d613 6466 o->op_private |= OPpSLICE;
01020589
GS		 6467 break;
6468 case OP_AELEM:
6469 o->op_flags |= OPf_SPECIAL;
6470 /* FALL THROUGH */
6471 case OP_HELEM:
6472 break;
6473 default:
6474 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 6475 OP_DESC(o));
01020589 6476 }
7332a6c4
VP		 6477 if (kid->op_private & OPpLVAL_INTRO)
6478 o->op_private |= OPpLVAL_INTRO;
93c66552 6479 op_null(kid);
79072805 6480 }
11343788 6481 return o;
79072805
LW		 6482}
6483
6484OP *
96e176bf
CL		 6485Perl_ck_die(pTHX_ OP *o)
6486{
7918f24d
NC		 6487 PERL_ARGS_ASSERT_CK_DIE;
6488
96e176bf
CL		 6489#ifdef VMS
6490 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6491#endif
6492 return ck_fun(o);
6493}
6494
6495OP *
cea2e8a9 6496Perl_ck_eof(pTHX_ OP *o)
79072805 6497{
97aff369 6498 dVAR;
79072805 6499
7918f24d
NC		 6500 PERL_ARGS_ASSERT_CK_EOF;
6501
11343788
MB		 6502 if (o->op_flags & OPf_KIDS) {
6503 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 6504 OP * const newop
6505 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 6506#ifdef PERL_MAD
6507 op_getmad(o,newop,'O');
6508#else
11343788 6509 op_free(o);
eb8433b7
NC		 6510#endif
6511 o = newop;
8990e307 6512 }
11343788 6513 return ck_fun(o);
79072805 6514 }
11343788 6515 return o;
79072805
LW		 6516}
6517
6518OP *
cea2e8a9 6519Perl_ck_eval(pTHX_ OP *o)
79072805 6520{
27da23d5 6521 dVAR;
7918f24d
NC		 6522
6523 PERL_ARGS_ASSERT_CK_EVAL;
6524
3280af22 6525 PL_hints |= HINT_BLOCK_SCOPE;
11343788 6526 if (o->op_flags & OPf_KIDS) {
46c461b5 6527 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 6528
93a17b20 6529 if (!kid) {
11343788 6530 o->op_flags &= ~OPf_KIDS;
93c66552 6531 op_null(o);
79072805 6532 }
b14574b4 6533 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 6534 LOGOP *enter;
eb8433b7 6535#ifdef PERL_MAD
1d866c12 6536 OP* const oldo = o;
eb8433b7 6537#endif
79072805 6538
11343788 6539 cUNOPo->op_first = 0;
eb8433b7 6540#ifndef PERL_MAD
11343788 6541 op_free(o);
eb8433b7 6542#endif
79072805 6543
b7dc083c 6544 NewOp(1101, enter, 1, LOGOP);
79072805 6545 enter->op_type = OP_ENTERTRY;
22c35a8c 6546 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 6547 enter->op_private = 0;
6548
6549 /* establish postfix order */
6550 enter->op_next = (OP*)enter;
6551
3a7a94e2
RGS		 6552 CHECKOP(OP_ENTERTRY, enter);
6553
11343788
MB		 6554 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6555 o->op_type = OP_LEAVETRY;
22c35a8c 6556 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 6557 enter->op_other = o;
eb8433b7 6558 op_getmad(oldo,o,'O');
11343788 6559 return o;
79072805 6560 }
b5c19bd7 6561 else {
473986ff 6562 scalar((OP*)kid);
b5c19bd7
DM		 6563 PL_cv_has_eval = 1;
6564 }
79072805
LW		 6565 }
6566 else {
eb8433b7 6567#ifdef PERL_MAD
1d866c12 6568 OP* const oldo = o;
eb8433b7 6569#else
11343788 6570 op_free(o);
eb8433b7 6571#endif
54b9620d 6572 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
eb8433b7 6573 op_getmad(oldo,o,'O');
79072805 6574 }
3280af22 6575 o->op_targ = (PADOFFSET)PL_hints;
7168684c 6576 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
996c9baa
VP		 6577 /* Store a copy of %^H that pp_entereval can pick up. */
6578 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
ad64d0ec 6579 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
0d863452
RH		 6580 cUNOPo->op_first->op_sibling = hhop;
6581 o->op_private |= OPpEVAL_HAS_HH;
6582 }
11343788 6583 return o;
79072805
LW		 6584}
6585
6586OP *
d98f61e7
GS		 6587Perl_ck_exit(pTHX_ OP *o)
6588{
7918f24d
NC		 6589 PERL_ARGS_ASSERT_CK_EXIT;
6590
d98f61e7 6591#ifdef VMS
551405c4 6592 HV * const table = GvHV(PL_hintgv);
d98f61e7 6593 if (table) {
a4fc7abc 6594 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 6595 if (svp && *svp && SvTRUE(*svp))
6596 o->op_private |= OPpEXIT_VMSISH;
6597 }
96e176bf 6598 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 6599#endif
6600 return ck_fun(o);
6601}
6602
6603OP *
cea2e8a9 6604Perl_ck_exec(pTHX_ OP *o)
79072805 6605{
7918f24d
NC		 6606 PERL_ARGS_ASSERT_CK_EXEC;
6607
11343788 6608 if (o->op_flags & OPf_STACKED) {
6867be6d 6609 OP *kid;
11343788
MB		 6610 o = ck_fun(o);
6611 kid = cUNOPo->op_first->op_sibling;
8990e307 6612 if (kid->op_type == OP_RV2GV)
93c66552 6613 op_null(kid);
79072805 6614 }
463ee0b2 6615 else
11343788
MB		 6616 o = listkids(o);
6617 return o;
79072805
LW		 6618}
6619
6620OP *
cea2e8a9 6621Perl_ck_exists(pTHX_ OP *o)
5f05dabc 6622{
97aff369 6623 dVAR;
7918f24d
NC		 6624
6625 PERL_ARGS_ASSERT_CK_EXISTS;
6626
5196be3e
MB		 6627 o = ck_fun(o);
6628 if (o->op_flags & OPf_KIDS) {
46c461b5 6629 OP * const kid = cUNOPo->op_first;
afebc493
GS		 6630 if (kid->op_type == OP_ENTERSUB) {
6631 (void) ref(kid, o->op_type);
13765c85
DM		 6632 if (kid->op_type != OP_RV2CV
6633 && !(PL_parser && PL_parser->error_count))
afebc493 6634 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 6635 OP_DESC(o));
afebc493
GS		 6636 o->op_private |= OPpEXISTS_SUB;
6637 }
6638 else if (kid->op_type == OP_AELEM)
01020589
GS		 6639 o->op_flags |= OPf_SPECIAL;
6640 else if (kid->op_type != OP_HELEM)
b0fdf69e 6641 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
53e06cf0 6642 OP_DESC(o));
93c66552 6643 op_null(kid);
5f05dabc 6644 }
5196be3e 6645 return o;
5f05dabc 6646}
6647
79072805 6648OP *
cea2e8a9 6649Perl_ck_rvconst(pTHX_ register OP *o)
79072805 6650{
27da23d5 6651 dVAR;
0bd48802 6652 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 6653
7918f24d
NC		 6654 PERL_ARGS_ASSERT_CK_RVCONST;
6655
3280af22 6656 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 6657 if (o->op_type == OP_RV2CV)
6658 o->op_private &= ~1;
6659
79072805 6660 if (kid->op_type == OP_CONST) {
44a8e56a 6661 int iscv;
6662 GV *gv;
504618e9 6663 SV * const kidsv = kid->op_sv;
44a8e56a 6664
779c5bc9
GS		 6665 /* Is it a constant from cv_const_sv()? */
6666 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 6667 SV * const rsv = SvRV(kidsv);
42d0e0b7 6668 const svtype type = SvTYPE(rsv);
bd61b366 6669 const char *badtype = NULL;
779c5bc9
GS		 6670
6671 switch (o->op_type) {
6672 case OP_RV2SV:
42d0e0b7 6673 if (type > SVt_PVMG)
779c5bc9
GS		 6674 badtype = "a SCALAR";
6675 break;
6676 case OP_RV2AV:
42d0e0b7 6677 if (type != SVt_PVAV)
779c5bc9
GS		 6678 badtype = "an ARRAY";
6679 break;
6680 case OP_RV2HV:
42d0e0b7 6681 if (type != SVt_PVHV)
779c5bc9 6682 badtype = "a HASH";
779c5bc9
GS		 6683 break;
6684 case OP_RV2CV:
42d0e0b7 6685 if (type != SVt_PVCV)
779c5bc9
GS		 6686 badtype = "a CODE";
6687 break;
6688 }
6689 if (badtype)
cea2e8a9 6690 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 6691 return o;
6692 }
ce10b5d1
RGS		 6693 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6694 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6695 /* If this is an access to a stash, disable "strict refs", because
6696 * stashes aren't auto-vivified at compile-time (unless we store
6697 * symbols in them), and we don't want to produce a run-time
6698 * stricture error when auto-vivifying the stash. */
6699 const char *s = SvPV_nolen(kidsv);
6700 const STRLEN l = SvCUR(kidsv);
6701 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6702 o->op_private &= ~HINT_STRICT_REFS;
6703 }
6704 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 6705 const char *badthing;
5dc0d613 6706 switch (o->op_type) {
44a8e56a 6707 case OP_RV2SV:
6708 badthing = "a SCALAR";
6709 break;
6710 case OP_RV2AV:
6711 badthing = "an ARRAY";
6712 break;
6713 case OP_RV2HV:
6714 badthing = "a HASH";
6715 break;
5f66b61c
AL		 6716 default:
6717 badthing = NULL;
6718 break;
44a8e56a 6719 }
6720 if (badthing)
1c846c1f 6721 Perl_croak(aTHX_
95b63a38 6722 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
be2597df 6723 SVfARG(kidsv), badthing);
44a8e56a 6724 }
93233ece
CS		 6725 /*
6726 * This is a little tricky. We only want to add the symbol if we
6727 * didn't add it in the lexer. Otherwise we get duplicate strict
6728 * warnings. But if we didn't add it in the lexer, we must at
6729 * least pretend like we wanted to add it even if it existed before,
6730 * or we get possible typo warnings. OPpCONST_ENTERED says
6731 * whether the lexer already added THIS instance of this symbol.
6732 */
5196be3e 6733 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 6734 do {
7a5fd60d 6735 gv = gv_fetchsv(kidsv,
748a9306 6736 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 6737 iscv
6738 ? SVt_PVCV
11343788 6739 : o->op_type == OP_RV2SV
a0d0e21e 6740 ? SVt_PV
11343788 6741 : o->op_type == OP_RV2AV
a0d0e21e 6742 ? SVt_PVAV
11343788 6743 : o->op_type == OP_RV2HV
a0d0e21e
LW		 6744 ? SVt_PVHV
6745 : SVt_PVGV);
93233ece
CS		 6746 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6747 if (gv) {
6748 kid->op_type = OP_GV;
6749 SvREFCNT_dec(kid->op_sv);
350de78d 6750#ifdef USE_ITHREADS
638eceb6 6751 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 6752 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 6753 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 6754 GvIN_PAD_on(gv);
ad64d0ec 6755 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
350de78d 6756#else
b37c2d43 6757 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 6758#endif
23f1ca44 6759 kid->op_private = 0;
76cd736e 6760 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 6761 }
79072805 6762 }
11343788 6763 return o;
79072805
LW		 6764}
6765
6766OP *
cea2e8a9 6767Perl_ck_ftst(pTHX_ OP *o)
79072805 6768{
27da23d5 6769 dVAR;
6867be6d 6770 const I32 type = o->op_type;
79072805 6771
7918f24d
NC		 6772 PERL_ARGS_ASSERT_CK_FTST;
6773
d0dca557 6774 if (o->op_flags & OPf_REF) {
6f207bd3 6775 NOOP;
d0dca557
JD		 6776 }
6777 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 6778 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 6779 const OPCODE kidtype = kid->op_type;
79072805 6780
1496a290 6781 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 6782 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 6783 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 6784#ifdef PERL_MAD
6785 op_getmad(o,newop,'O');
6786#else
11343788 6787 op_free(o);
eb8433b7 6788#endif
1d866c12 6789 return newop;
79072805 6790 }
6ecf81d6 6791 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
1af34c76 6792 o->op_private |= OPpFT_ACCESS;
1496a290
AL		 6793 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6794 && kidtype != OP_STAT && kidtype != OP_LSTAT)
fbb0b3b3 6795 o->op_private |= OPpFT_STACKED;
79072805
LW		 6796 }
6797 else {
eb8433b7 6798#ifdef PERL_MAD
1d866c12 6799 OP* const oldo = o;
eb8433b7 6800#else
11343788 6801 op_free(o);
eb8433b7 6802#endif
79072805 6803 if (type == OP_FTTTY)
8fde6460 6804 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 6805 else
d0dca557 6806 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 6807 op_getmad(oldo,o,'O');
79072805 6808 }
11343788 6809 return o;
79072805
LW		 6810}
6811
6812OP *
cea2e8a9 6813Perl_ck_fun(pTHX_ OP *o)
79072805 6814{
97aff369 6815 dVAR;
6867be6d 6816 const int type = o->op_type;
22c35a8c 6817 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 6818
7918f24d
NC		 6819 PERL_ARGS_ASSERT_CK_FUN;
6820
11343788 6821 if (o->op_flags & OPf_STACKED) {
79072805
LW		 6822 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6823 oa &= ~OA_OPTIONAL;
6824 else
11343788 6825 return no_fh_allowed(o);
79072805
LW		 6826 }
6827
11343788 6828 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 6829 OP **tokid = &cLISTOPo->op_first;
6830 register OP *kid = cLISTOPo->op_first;
6831 OP *sibl;
6832 I32 numargs = 0;
6833
8990e307 6834 if (kid->op_type == OP_PUSHMARK ||
155aba94 6835 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 6836 {
79072805
LW		 6837 tokid = &kid->op_sibling;
6838 kid = kid->op_sibling;
6839 }
22c35a8c 6840 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 6841 *tokid = kid = newDEFSVOP();
79072805
LW		 6842
6843 while (oa && kid) {
6844 numargs++;
6845 sibl = kid->op_sibling;
eb8433b7
NC		 6846#ifdef PERL_MAD
6847 if (!sibl && kid->op_type == OP_STUB) {
6848 numargs--;
6849 break;
6850 }
6851#endif
79072805
LW		 6852 switch (oa & 7) {
6853 case OA_SCALAR:
62c18ce2
GS		 6854 /* list seen where single (scalar) arg expected? */
6855 if (numargs == 1 && !(oa >> 4)
6856 && kid->op_type == OP_LIST && type != OP_SCALAR)
6857 {
6858 return too_many_arguments(o,PL_op_desc[type]);
6859 }
79072805
LW		 6860 scalar(kid);
6861 break;
6862 case OA_LIST:
6863 if (oa < 16) {
6864 kid = 0;
6865 continue;
6866 }
6867 else
6868 list(kid);
6869 break;
6870 case OA_AVREF:
936edb8b 6871 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 6872 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 6873 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 6874 "Useless use of %s with no values",
936edb8b 6875 PL_op_desc[type]);
b2ffa427 6876
79072805 6877 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6878 (kid->op_private & OPpCONST_BARE))
6879 {
551405c4 6880 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 6881 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
12bcd1a6
PM		 6882 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6883 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d 6884 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
be2597df 6885 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6886#ifdef PERL_MAD
6887 op_getmad(kid,newop,'K');
6888#else
79072805 6889 op_free(kid);
eb8433b7 6890#endif
79072805
LW		 6891 kid = newop;
6892 kid->op_sibling = sibl;
6893 *tokid = kid;
6894 }
8990e307 6895 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 6896 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 6897 mod(kid, type);
79072805
LW		 6898 break;
6899 case OA_HVREF:
6900 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6901 (kid->op_private & OPpCONST_BARE))
6902 {
551405c4 6903 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 6904 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
12bcd1a6
PM		 6905 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6906 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d 6907 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
be2597df 6908 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6909#ifdef PERL_MAD
6910 op_getmad(kid,newop,'K');
6911#else
79072805 6912 op_free(kid);
eb8433b7 6913#endif
79072805
LW		 6914 kid = newop;
6915 kid->op_sibling = sibl;
6916 *tokid = kid;
6917 }
8990e307 6918 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 6919 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 6920 mod(kid, type);
79072805
LW		 6921 break;
6922 case OA_CVREF:
6923 {
551405c4 6924 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 6925 kid->op_sibling = 0;
6926 linklist(kid);
6927 newop->op_next = newop;
6928 kid = newop;
6929 kid->op_sibling = sibl;
6930 *tokid = kid;
6931 }
6932 break;
6933 case OA_FILEREF:
c340be78 6934 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 6935 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6936 (kid->op_private & OPpCONST_BARE))
6937 {
0bd48802 6938 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 6939 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 6940 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 6941 kid == cLISTOPo->op_last)
364daeac 6942 cLISTOPo->op_last = newop;
eb8433b7
NC		 6943#ifdef PERL_MAD
6944 op_getmad(kid,newop,'K');
6945#else
79072805 6946 op_free(kid);
eb8433b7 6947#endif
79072805
LW		 6948 kid = newop;
6949 }
1ea32a52
GS		 6950 else if (kid->op_type == OP_READLINE) {
6951 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 6952 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 6953 }
79072805 6954 else {
35cd451c 6955 I32 flags = OPf_SPECIAL;
a6c40364 6956 I32 priv = 0;
2c8ac474
GS		 6957 PADOFFSET targ = 0;
6958
35cd451c 6959 /* is this op a FH constructor? */
853846ea 6960 if (is_handle_constructor(o,numargs)) {
bd61b366 6961 const char *name = NULL;
dd2155a4 6962 STRLEN len = 0;
2c8ac474
GS		 6963
6964 flags = 0;
6965 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 6966 * need to "prove" flag does not mean something
6967 * else already - NI-S 1999/05/07
2c8ac474
GS		 6968 */
6969 priv = OPpDEREF;
6970 if (kid->op_type == OP_PADSV) {
f8503592
NC		 6971 SV *const namesv
6972 = PAD_COMPNAME_SV(kid->op_targ);
6973 name = SvPV_const(namesv, len);
2c8ac474
GS		 6974 }
6975 else if (kid->op_type == OP_RV2SV
6976 && kUNOP->op_first->op_type == OP_GV)
6977 {
0bd48802 6978 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 6979 name = GvNAME(gv);
6980 len = GvNAMELEN(gv);
6981 }
afd1915d
GS		 6982 else if (kid->op_type == OP_AELEM
6983 || kid->op_type == OP_HELEM)
6984 {
735fec84 6985 OP *firstop;
551405c4 6986 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 6987 name = NULL;
551405c4 6988 if (op) {
a0714e2c 6989 SV *tmpstr = NULL;
551405c4 6990 const char * const a =
666ea192
JH		 6991 kid->op_type == OP_AELEM ?
6992 "[]" : "{}";
0c4b0a3f
JH		 6993 if (((op->op_type == OP_RV2AV) ||
6994 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 6995 (firstop = ((UNOP*)op)->op_first) &&
6996 (firstop->op_type == OP_GV)) {
0c4b0a3f 6997 /* packagevar $a[] or $h{} */
735fec84 6998 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 6999 if (gv)
7000 tmpstr =
7001 Perl_newSVpvf(aTHX_
7002 "%s%c...%c",
7003 GvNAME(gv),
7004 a[0], a[1]);
7005 }
7006 else if (op->op_type == OP_PADAV
7007 || op->op_type == OP_PADHV) {
7008 /* lexicalvar $a[] or $h{} */
551405c4 7009 const char * const padname =
0c4b0a3f
JH		 7010 PAD_COMPNAME_PV(op->op_targ);
7011 if (padname)
7012 tmpstr =
7013 Perl_newSVpvf(aTHX_
7014 "%s%c...%c",
7015 padname + 1,
7016 a[0], a[1]);
0c4b0a3f
JH		 7017 }
7018 if (tmpstr) {
93524f2b 7019 name = SvPV_const(tmpstr, len);
0c4b0a3f
JH		 7020 sv_2mortal(tmpstr);
7021 }
7022 }
7023 if (!name) {
7024 name = "__ANONIO__";
7025 len = 10;
7026 }
7027 mod(kid, type);
afd1915d 7028 }
2c8ac474
GS		 7029 if (name) {
7030 SV *namesv;
7031 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 7032 namesv = PAD_SVl(targ);
862a34c6 7033 SvUPGRADE(namesv, SVt_PV);
2c8ac474 7034 if (*name != '$')
76f68e9b 7035 sv_setpvs(namesv, "$");
2c8ac474
GS		 7036 sv_catpvn(namesv, name, len);
7037 }
853846ea 7038 }
79072805 7039 kid->op_sibling = 0;
35cd451c 7040 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 7041 kid->op_targ = targ;
7042 kid->op_private |= priv;
79072805
LW		 7043 }
7044 kid->op_sibling = sibl;
7045 *tokid = kid;
7046 }
7047 scalar(kid);
7048 break;
7049 case OA_SCALARREF:
a0d0e21e 7050 mod(scalar(kid), type);
79072805
LW		 7051 break;
7052 }
7053 oa >>= 4;
7054 tokid = &kid->op_sibling;
7055 kid = kid->op_sibling;
7056 }
eb8433b7
NC		 7057#ifdef PERL_MAD
7058 if (kid && kid->op_type != OP_STUB)
7059 return too_many_arguments(o,OP_DESC(o));
7060 o->op_private |= numargs;
7061#else
7062 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 7063 o->op_private |= numargs;
79072805 7064 if (kid)
53e06cf0 7065 return too_many_arguments(o,OP_DESC(o));
eb8433b7 7066#endif
11343788 7067 listkids(o);
79072805 7068 }
22c35a8c 7069 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 7070#ifdef PERL_MAD
c7fe699d 7071 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 7072 op_getmad(o,newop,'O');
c7fe699d 7073 return newop;
c56915e3 7074#else
c7fe699d 7075 /* Ordering of these two is important to keep f_map.t passing. */
11343788 7076 op_free(o);
c7fe699d 7077 return newUNOP(type, 0, newDEFSVOP());
c56915e3 7078#endif
a0d0e21e
LW		 7079 }
7080
79072805
LW		 7081 if (oa) {
7082 while (oa & OA_OPTIONAL)
7083 oa >>= 4;
7084 if (oa && oa != OA_LIST)
53e06cf0 7085 return too_few_arguments(o,OP_DESC(o));
79072805 7086 }
11343788 7087 return o;
79072805
LW		 7088}
7089
7090OP *
cea2e8a9 7091Perl_ck_glob(pTHX_ OP *o)
79072805 7092{
27da23d5 7093 dVAR;
fb73857a 7094 GV *gv;
7095
7918f24d
NC		 7096 PERL_ARGS_ASSERT_CK_GLOB;
7097
649da076 7098 o = ck_fun(o);
1f2bfc8a 7099 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 7100 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 7101
fafc274c 7102 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 7103 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7104 {
5c1737d1 7105 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 7106 }
b1cb66bf 7107
52bb0670 7108#if !defined(PERL_EXTERNAL_GLOB)
72b16652 7109 /* XXX this can be tightened up and made more failsafe. */
f444d496 7110 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 7111 GV *glob_gv;
72b16652 7112 ENTER;
00ca71c1 7113 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
a0714e2c 7114 newSVpvs("File::Glob"), NULL, NULL, NULL);
5c1737d1
NC		 7115 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7116 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7d3fb230 7117 GvCV(gv) = GvCV(glob_gv);
ad64d0ec 7118 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7d3fb230 7119 GvIMPORTED_CV_on(gv);
72b16652
GS		 7120 LEAVE;
7121 }
52bb0670 7122#endif /* PERL_EXTERNAL_GLOB */
72b16652 7123
b9f751c0 7124 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 7125 append_elem(OP_GLOB, o,
80252599 7126 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 7127 o->op_type = OP_LIST;
22c35a8c 7128 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 7129 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 7130 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 7131 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 7132 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 7133 append_elem(OP_LIST, o,
1f2bfc8a
MB		 7134 scalar(newUNOP(OP_RV2CV, 0,
7135 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 7136 o = newUNOP(OP_NULL, 0, ck_subr(o));
7137 o->op_targ = OP_GLOB; /* hint at what it used to be */
7138 return o;
b1cb66bf 7139 }
7140 gv = newGVgen("main");
a0d0e21e 7141 gv_IOadd(gv);
11343788
MB		 7142 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7143 scalarkids(o);
649da076 7144 return o;
79072805
LW		 7145}
7146
7147OP *
cea2e8a9 7148Perl_ck_grep(pTHX_ OP *o)
79072805 7149{
27da23d5 7150 dVAR;
03ca120d 7151 LOGOP *gwop = NULL;
79072805 7152 OP *kid;
6867be6d 7153 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 7154 PADOFFSET offset;
79072805 7155
7918f24d
NC		 7156 PERL_ARGS_ASSERT_CK_GREP;
7157
22c35a8c 7158 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
13765c85 7159 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
aeea060c 7160
11343788 7161 if (o->op_flags & OPf_STACKED) {
a0d0e21e 7162 OP* k;
11343788
MB		 7163 o = ck_sort(o);
7164 kid = cLISTOPo->op_first->op_sibling;
d09ad856
BS		 7165 if (!cUNOPx(kid)->op_next)
7166 Perl_croak(aTHX_ "panic: ck_grep");
e3c9a8b9 7167 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
a0d0e21e
LW		 7168 kid = k;
7169 }
03ca120d 7170 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 7171 kid->op_next = (OP*)gwop;
11343788 7172 o->op_flags &= ~OPf_STACKED;
93a17b20 7173 }
11343788 7174 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 7175 if (type == OP_MAPWHILE)
7176 list(kid);
7177 else
7178 scalar(kid);
11343788 7179 o = ck_fun(o);
13765c85 7180 if (PL_parser && PL_parser->error_count)
11343788 7181 return o;
aeea060c 7182 kid = cLISTOPo->op_first->op_sibling;
79072805 7183 if (kid->op_type != OP_NULL)
cea2e8a9 7184 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 7185 kid = kUNOP->op_first;
7186
03ca120d
MHM		 7187 if (!gwop)
7188 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 7189 gwop->op_type = type;
22c35a8c 7190 gwop->op_ppaddr = PL_ppaddr[type];
11343788 7191 gwop->op_first = listkids(o);
79072805 7192 gwop->op_flags |= OPf_KIDS;
79072805 7193 gwop->op_other = LINKLIST(kid);
79072805 7194 kid->op_next = (OP*)gwop;
59f00321 7195 offset = pad_findmy("$_");
00b1698f 7196 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 7197 o->op_private = gwop->op_private = 0;
7198 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7199 }
7200 else {
7201 o->op_private = gwop->op_private = OPpGREP_LEX;
7202 gwop->op_targ = o->op_targ = offset;
7203 }
79072805 7204
11343788 7205 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 7206 if (!kid || !kid->op_sibling)
53e06cf0 7207 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 7208 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7209 mod(kid, OP_GREPSTART);
7210
79072805
LW		 7211 return (OP*)gwop;
7212}
7213
7214OP *
cea2e8a9 7215Perl_ck_index(pTHX_ OP *o)
79072805 7216{
7918f24d
NC		 7217 PERL_ARGS_ASSERT_CK_INDEX;
7218
11343788
MB		 7219 if (o->op_flags & OPf_KIDS) {
7220 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 7221 if (kid)
7222 kid = kid->op_sibling; /* get past "big" */
79072805 7223 if (kid && kid->op_type == OP_CONST)
2779dcf1 7224 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 7225 }
11343788 7226 return ck_fun(o);
79072805
LW		 7227}
7228
7229OP *
cea2e8a9 7230Perl_ck_lfun(pTHX_ OP *o)
79072805 7231{
6867be6d 7232 const OPCODE type = o->op_type;
7918f24d
NC		 7233
7234 PERL_ARGS_ASSERT_CK_LFUN;
7235
5dc0d613 7236 return modkids(ck_fun(o), type);
79072805
LW		 7237}
7238
7239OP *
cea2e8a9 7240Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 7241{
7918f24d
NC		 7242 PERL_ARGS_ASSERT_CK_DEFINED;
7243
12bcd1a6 7244 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 7245 switch (cUNOPo->op_first->op_type) {
7246 case OP_RV2AV:
a8739d98
JH		 7247 /* This is needed for
7248 if (defined %stash::)
7249 to work. Do not break Tk.
7250 */
1c846c1f 7251 break; /* Globals via GV can be undef */
d0334bed
GS		 7252 case OP_PADAV:
7253 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 7254 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 7255 "defined(@array) is deprecated");
12bcd1a6 7256 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 7257 "\t(Maybe you should just omit the defined()?)\n");
69794302 7258 break;
d0334bed 7259 case OP_RV2HV:
a8739d98
JH		 7260 /* This is needed for
7261 if (defined %stash::)
7262 to work. Do not break Tk.
7263 */
1c846c1f 7264 break; /* Globals via GV can be undef */
d0334bed 7265 case OP_PADHV:
12bcd1a6 7266 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 7267 "defined(%%hash) is deprecated");
12bcd1a6 7268 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 7269 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 7270 break;
7271 default:
7272 /* no warning */
7273 break;
7274 }
69794302
MJD		 7275 }
7276 return ck_rfun(o);
7277}
7278
7279OP *
e4b7ebf3
RGS		 7280Perl_ck_readline(pTHX_ OP *o)
7281{
7918f24d
NC		 7282 PERL_ARGS_ASSERT_CK_READLINE;
7283
e4b7ebf3
RGS		 7284 if (!(o->op_flags & OPf_KIDS)) {
7285 OP * const newop
7286 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7287#ifdef PERL_MAD
7288 op_getmad(o,newop,'O');
7289#else
7290 op_free(o);
7291#endif
7292 return newop;
7293 }
7294 return o;
7295}
7296
7297OP *
cea2e8a9 7298Perl_ck_rfun(pTHX_ OP *o)
8990e307 7299{
6867be6d 7300 const OPCODE type = o->op_type;
7918f24d
NC		 7301
7302 PERL_ARGS_ASSERT_CK_RFUN;
7303
5dc0d613 7304 return refkids(ck_fun(o), type);
8990e307
LW		 7305}
7306
7307OP *
cea2e8a9 7308Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 7309{
7310 register OP *kid;
aeea060c 7311
7918f24d
NC		 7312 PERL_ARGS_ASSERT_CK_LISTIOB;
7313
11343788 7314 kid = cLISTOPo->op_first;
79072805 7315 if (!kid) {
11343788
MB		 7316 o = force_list(o);
7317 kid = cLISTOPo->op_first;
79072805
LW		 7318 }
7319 if (kid->op_type == OP_PUSHMARK)
7320 kid = kid->op_sibling;
11343788 7321 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 7322 kid = kid->op_sibling;
7323 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7324 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 7325 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 7326 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 7327 cLISTOPo->op_first->op_sibling = kid;
7328 cLISTOPo->op_last = kid;
79072805
LW		 7329 kid = kid->op_sibling;
7330 }
7331 }
b2ffa427 7332
79072805 7333 if (!kid)
54b9620d 7334 append_elem(o->op_type, o, newDEFSVOP());
79072805 7335
2de3dbcc 7336 return listkids(o);
bbce6d69 7337}
7338
7339OP *
0d863452
RH		 7340Perl_ck_smartmatch(pTHX_ OP *o)
7341{
97aff369 7342 dVAR;
0d863452
RH		 7343 if (0 == (o->op_flags & OPf_SPECIAL)) {
7344 OP *first = cBINOPo->op_first;
7345 OP *second = first->op_sibling;
7346
7347 /* Implicitly take a reference to an array or hash */
5f66b61c 7348 first->op_sibling = NULL;
0d863452
RH		 7349 first = cBINOPo->op_first = ref_array_or_hash(first);
7350 second = first->op_sibling = ref_array_or_hash(second);
7351
7352 /* Implicitly take a reference to a regular expression */
7353 if (first->op_type == OP_MATCH) {
7354 first->op_type = OP_QR;
7355 first->op_ppaddr = PL_ppaddr[OP_QR];
7356 }
7357 if (second->op_type == OP_MATCH) {
7358 second->op_type = OP_QR;
7359 second->op_ppaddr = PL_ppaddr[OP_QR];
7360 }
7361 }
7362
7363 return o;
7364}
7365
7366
7367OP *
b162f9ea
IZ		 7368Perl_ck_sassign(pTHX_ OP *o)
7369{
3088bf26 7370 dVAR;
1496a290 7371 OP * const kid = cLISTOPo->op_first;
7918f24d
NC		 7372
7373 PERL_ARGS_ASSERT_CK_SASSIGN;
7374
b162f9ea
IZ		 7375 /* has a disposable target? */
7376 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 7377 && !(kid->op_flags & OPf_STACKED)
7378 /* Cannot steal the second time! */
1b438339
GG		 7379 && !(kid->op_private & OPpTARGET_MY)
7380 /* Keep the full thing for madskills */
7381 && !PL_madskills
7382 )
b162f9ea 7383 {
551405c4 7384 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 7385
7386 /* Can just relocate the target. */
2c2d71f5
JH		 7387 if (kkid && kkid->op_type == OP_PADSV
7388 && !(kkid->op_private & OPpLVAL_INTRO))
7389 {
b162f9ea 7390 kid->op_targ = kkid->op_targ;
743e66e6 7391 kkid->op_targ = 0;
b162f9ea
IZ		 7392 /* Now we do not need PADSV and SASSIGN. */
7393 kid->op_sibling = o->op_sibling; /* NULL */
7394 cLISTOPo->op_first = NULL;
7395 op_free(o);
7396 op_free(kkid);
7397 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7398 return kid;
7399 }
7400 }
c5917253
NC		 7401 if (kid->op_sibling) {
7402 OP *kkid = kid->op_sibling;
7403 if (kkid->op_type == OP_PADSV
7404 && (kkid->op_private & OPpLVAL_INTRO)
7405 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7406 const PADOFFSET target = kkid->op_targ;
7407 OP *const other = newOP(OP_PADSV,
7408 kkid->op_flags
7409 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7410 OP *const first = newOP(OP_NULL, 0);
7411 OP *const nullop = newCONDOP(0, first, o, other);
7412 OP *const condop = first->op_next;
7413 /* hijacking PADSTALE for uninitialized state variables */
7414 SvPADSTALE_on(PAD_SVl(target));
7415
7416 condop->op_type = OP_ONCE;
7417 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7418 condop->op_targ = target;
7419 other->op_targ = target;
7420
95562366
NC		 7421 /* Because we change the type of the op here, we will skip the
7422 assinment binop->op_last = binop->op_first->op_sibling; at the
7423 end of Perl_newBINOP(). So need to do it here. */
7424 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7425
c5917253
NC		 7426 return nullop;
7427 }
7428 }
b162f9ea
IZ		 7429 return o;
7430}
7431
7432OP *
cea2e8a9 7433Perl_ck_match(pTHX_ OP *o)
79072805 7434{
97aff369 7435 dVAR;
7918f24d
NC		 7436
7437 PERL_ARGS_ASSERT_CK_MATCH;
7438
0d863452 7439 if (o->op_type != OP_QR && PL_compcv) {
9f7d9405 7440 const PADOFFSET offset = pad_findmy("$_");
00b1698f 7441 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 7442 o->op_targ = offset;
7443 o->op_private |= OPpTARGET_MY;
7444 }
7445 }
7446 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7447 o->op_private |= OPpRUNTIME;
11343788 7448 return o;
79072805
LW		 7449}
7450
7451OP *
f5d5a27c
CS		 7452Perl_ck_method(pTHX_ OP *o)
7453{
551405c4 7454 OP * const kid = cUNOPo->op_first;
7918f24d
NC		 7455
7456 PERL_ARGS_ASSERT_CK_METHOD;
7457
f5d5a27c
CS		 7458 if (kid->op_type == OP_CONST) {
7459 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 7460 const char * const method = SvPVX_const(sv);
7461 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 7462 OP *cmop;
1c846c1f 7463 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
a4fc7abc 7464 sv = newSVpvn_share(method, SvCUR(sv), 0);
1c846c1f
NIS		 7465 }
7466 else {
a0714e2c 7467 kSVOP->op_sv = NULL;
1c846c1f 7468 }
f5d5a27c 7469 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 7470#ifdef PERL_MAD
7471 op_getmad(o,cmop,'O');
7472#else
f5d5a27c 7473 op_free(o);
eb8433b7 7474#endif
f5d5a27c
CS		 7475 return cmop;
7476 }
7477 }
7478 return o;
7479}
7480
7481OP *
cea2e8a9 7482Perl_ck_null(pTHX_ OP *o)
79072805 7483{
7918f24d 7484 PERL_ARGS_ASSERT_CK_NULL;
96a5add6 7485 PERL_UNUSED_CONTEXT;
11343788 7486 return o;
79072805
LW		 7487}
7488
7489OP *
16fe6d59
GS		 7490Perl_ck_open(pTHX_ OP *o)
7491{
97aff369 7492 dVAR;
551405c4 7493 HV * const table = GvHV(PL_hintgv);
7918f24d
NC		 7494
7495 PERL_ARGS_ASSERT_CK_OPEN;
7496
16fe6d59 7497 if (table) {
a4fc7abc 7498 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 7499 if (svp && *svp) {
a79b25b7
VP		 7500 STRLEN len = 0;
7501 const char *d = SvPV_const(*svp, len);
7502 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 7503 if (mode & O_BINARY)
7504 o->op_private |= OPpOPEN_IN_RAW;
7505 else if (mode & O_TEXT)
7506 o->op_private |= OPpOPEN_IN_CRLF;
7507 }
7508
a4fc7abc 7509 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 7510 if (svp && *svp) {
a79b25b7
VP		 7511 STRLEN len = 0;
7512 const char *d = SvPV_const(*svp, len);
7513 const I32 mode = mode_from_discipline(d, len);
16fe6d59
GS		 7514 if (mode & O_BINARY)
7515 o->op_private |= OPpOPEN_OUT_RAW;
7516 else if (mode & O_TEXT)
7517 o->op_private |= OPpOPEN_OUT_CRLF;
7518 }
7519 }
8d7403e6
RGS		 7520 if (o->op_type == OP_BACKTICK) {
7521 if (!(o->op_flags & OPf_KIDS)) {
e4b7ebf3
RGS		 7522 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7523#ifdef PERL_MAD
7524 op_getmad(o,newop,'O');
7525#else
8d7403e6 7526 op_free(o);
e4b7ebf3
RGS		 7527#endif
7528 return newop;
8d7403e6 7529 }
16fe6d59 7530 return o;
8d7403e6 7531 }
3b82e551
JH		 7532 {
7533 /* In case of three-arg dup open remove strictness
7534 * from the last arg if it is a bareword. */
551405c4
AL		 7535 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7536 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 7537 OP *oa;
b15aece3 7538 const char *mode;
3b82e551
JH		 7539
7540 if ((last->op_type == OP_CONST) && /* The bareword. */
7541 (last->op_private & OPpCONST_BARE) &&
7542 (last->op_private & OPpCONST_STRICT) &&
7543 (oa = first->op_sibling) && /* The fh. */
7544 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 7545 (oa->op_type == OP_CONST) &&
3b82e551 7546 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 7547 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 7548 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7549 (last == oa->op_sibling)) /* The bareword. */
7550 last->op_private &= ~OPpCONST_STRICT;
7551 }
16fe6d59
GS		 7552 return ck_fun(o);
7553}
7554
7555OP *
cea2e8a9 7556Perl_ck_repeat(pTHX_ OP *o)
79072805 7557{
7918f24d
NC		 7558 PERL_ARGS_ASSERT_CK_REPEAT;
7559
11343788
MB		 7560 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7561 o->op_private |= OPpREPEAT_DOLIST;
7562 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 7563 }
7564 else
11343788
MB		 7565 scalar(o);
7566 return o;
79072805
LW		 7567}
7568
7569OP *
cea2e8a9 7570Perl_ck_require(pTHX_ OP *o)
8990e307 7571{
97aff369 7572 dVAR;
a0714e2c 7573 GV* gv = NULL;
ec4ab249 7574
7918f24d
NC		 7575 PERL_ARGS_ASSERT_CK_REQUIRE;
7576
11343788 7577 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 7578 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 7579
7580 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 7581 SV * const sv = kid->op_sv;
5c144d81 7582 U32 was_readonly = SvREADONLY(sv);
8990e307 7583 char *s;
cfff9797
NC		 7584 STRLEN len;
7585 const char *end;
5c144d81
NC		 7586
7587 if (was_readonly) {
7588 if (SvFAKE(sv)) {
7589 sv_force_normal_flags(sv, 0);
7590 assert(!SvREADONLY(sv));
7591 was_readonly = 0;
7592 } else {
7593 SvREADONLY_off(sv);
7594 }
7595 }
7596
cfff9797
NC		 7597 s = SvPVX(sv);
7598 len = SvCUR(sv);
7599 end = s + len;
7600 for (; s < end; s++) {
a0d0e21e
LW		 7601 if (*s == ':' && s[1] == ':') {
7602 *s = '/';
5c6b2528 7603 Move(s+2, s+1, end - s - 1, char);
cfff9797 7604 --end;
a0d0e21e 7605 }
8990e307 7606 }
cfff9797 7607 SvEND_set(sv, end);
396482e1 7608 sv_catpvs(sv, ".pm");
5c144d81 7609 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 7610 }
7611 }
ec4ab249 7612
a72a1c8b
RGS		 7613 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7614 /* handle override, if any */
fafc274c 7615 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 7616 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 7617 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 7618 gv = gvp ? *gvp : NULL;
d6a985f2 7619 }
a72a1c8b 7620 }
ec4ab249 7621
b9f751c0 7622 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 7623 OP * const kid = cUNOPo->op_first;
f11453cb
NC		 7624 OP * newop;
7625
ec4ab249 7626 cUNOPo->op_first = 0;
f11453cb 7627#ifndef PERL_MAD
ec4ab249 7628 op_free(o);
eb8433b7 7629#endif
f11453cb
NC		 7630 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7631 append_elem(OP_LIST, kid,
7632 scalar(newUNOP(OP_RV2CV, 0,
7633 newGVOP(OP_GV, 0,
7634 gv))))));
7635 op_getmad(o,newop,'O');
eb8433b7 7636 return newop;
ec4ab249
GA		 7637 }
7638
11343788 7639 return ck_fun(o);
8990e307
LW		 7640}
7641
78f9721b
SM		 7642OP *
7643Perl_ck_return(pTHX_ OP *o)
7644{
97aff369 7645 dVAR;
e91684bf 7646 OP *kid;
7918f24d
NC		 7647
7648 PERL_ARGS_ASSERT_CK_RETURN;
7649
e91684bf 7650 kid = cLISTOPo->op_first->op_sibling;
78f9721b 7651 if (CvLVALUE(PL_compcv)) {
e91684bf 7652 for (; kid; kid = kid->op_sibling)
78f9721b 7653 mod(kid, OP_LEAVESUBLV);
e91684bf
VP		 7654 } else {
7655 for (; kid; kid = kid->op_sibling)
7656 if ((kid->op_type == OP_NULL)
1c8a4223 7657 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
e91684bf 7658 /* This is a do block */
1c8a4223
VP		 7659 OP *op = kUNOP->op_first;
7660 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7661 op = cUNOPx(op)->op_first;
7662 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7663 /* Force the use of the caller's context */
7664 op->op_flags |= OPf_SPECIAL;
7665 }
e91684bf 7666 }
78f9721b 7667 }
e91684bf 7668
78f9721b
SM		 7669 return o;
7670}
7671
79072805 7672OP *
cea2e8a9 7673Perl_ck_select(pTHX_ OP *o)
79072805 7674{
27da23d5 7675 dVAR;
c07a80fd 7676 OP* kid;
7918f24d
NC		 7677
7678 PERL_ARGS_ASSERT_CK_SELECT;
7679
11343788
MB		 7680 if (o->op_flags & OPf_KIDS) {
7681 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 7682 if (kid && kid->op_sibling) {
11343788 7683 o->op_type = OP_SSELECT;
22c35a8c 7684 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 7685 o = ck_fun(o);
7686 return fold_constants(o);
79072805
LW		 7687 }
7688 }
11343788
MB		 7689 o = ck_fun(o);
7690 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 7691 if (kid && kid->op_type == OP_RV2GV)
7692 kid->op_private &= ~HINT_STRICT_REFS;
11343788 7693 return o;
79072805
LW		 7694}
7695
7696OP *
cea2e8a9 7697Perl_ck_shift(pTHX_ OP *o)
79072805 7698{
97aff369 7699 dVAR;
6867be6d 7700 const I32 type = o->op_type;
79072805 7701
7918f24d
NC		 7702 PERL_ARGS_ASSERT_CK_SHIFT;
7703
11343788 7704 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 7705 OP *argop;
eb8433b7
NC		 7706 /* FIXME - this can be refactored to reduce code in #ifdefs */
7707#ifdef PERL_MAD
1d866c12 7708 OP * const oldo = o;
eb8433b7 7709#else
11343788 7710 op_free(o);
eb8433b7 7711#endif
6d4ff0d2 7712 argop = newUNOP(OP_RV2AV, 0,
8fde6460 7713 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
eb8433b7
NC		 7714#ifdef PERL_MAD
7715 o = newUNOP(type, 0, scalar(argop));
7716 op_getmad(oldo,o,'O');
7717 return o;
7718#else
6d4ff0d2 7719 return newUNOP(type, 0, scalar(argop));
eb8433b7 7720#endif
79072805 7721 }
11343788 7722 return scalar(modkids(ck_fun(o), type));
79072805
LW		 7723}
7724
7725OP *
cea2e8a9 7726Perl_ck_sort(pTHX_ OP *o)
79072805 7727{
97aff369 7728 dVAR;
8e3f9bdf 7729 OP *firstkid;
bbce6d69 7730
7918f24d
NC		 7731 PERL_ARGS_ASSERT_CK_SORT;
7732
1496a290 7733 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
a4fc7abc 7734 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 7735 if (hinthv) {
a4fc7abc 7736 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 7737 if (svp) {
a4fc7abc 7738 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 7739 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7740 o->op_private |= OPpSORT_QSORT;
7741 if ((sorthints & HINT_SORT_STABLE) != 0)
7742 o->op_private |= OPpSORT_STABLE;
7743 }
7744 }
7745 }
7746
9ea6e965 7747 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 7748 simplify_sort(o);
8e3f9bdf
GS		 7749 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7750 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 7751 OP *k = NULL;
8e3f9bdf 7752 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 7753
463ee0b2 7754 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 7755 linklist(kid);
463ee0b2
LW		 7756 if (kid->op_type == OP_SCOPE) {
7757 k = kid->op_next;
7758 kid->op_next = 0;
79072805 7759 }
463ee0b2 7760 else if (kid->op_type == OP_LEAVE) {
11343788 7761 if (o->op_type == OP_SORT) {
93c66552 7762 op_null(kid); /* wipe out leave */
748a9306 7763 kid->op_next = kid;
463ee0b2 7764
748a9306
LW		 7765 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7766 if (k->op_next == kid)
7767 k->op_next = 0;
71a29c3c
GS		 7768 /* don't descend into loops */
7769 else if (k->op_type == OP_ENTERLOOP
7770 || k->op_type == OP_ENTERITER)
7771 {
7772 k = cLOOPx(k)->op_lastop;
7773 }
748a9306 7774 }
463ee0b2 7775 }
748a9306
LW		 7776 else
7777 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 7778 k = kLISTOP->op_first;
463ee0b2 7779 }
a2efc822 7780 CALL_PEEP(k);
a0d0e21e 7781
8e3f9bdf
GS		 7782 kid = firstkid;
7783 if (o->op_type == OP_SORT) {
7784 /* provide scalar context for comparison function/block */
7785 kid = scalar(kid);
a0d0e21e 7786 kid->op_next = kid;
8e3f9bdf 7787 }
a0d0e21e
LW		 7788 else
7789 kid->op_next = k;
11343788 7790 o->op_flags |= OPf_SPECIAL;
79072805 7791 }
c6e96bcb 7792 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 7793 op_null(firstkid);
8e3f9bdf
GS		 7794
7795 firstkid = firstkid->op_sibling;
79072805 7796 }
bbce6d69 7797
8e3f9bdf
GS		 7798 /* provide list context for arguments */
7799 if (o->op_type == OP_SORT)
7800 list(firstkid);
7801
11343788 7802 return o;
79072805 7803}
bda4119b
GS		 7804
7805STATIC void
cea2e8a9 7806S_simplify_sort(pTHX_ OP *o)
9c007264 7807{
97aff369 7808 dVAR;
9c007264
JH		 7809 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7810 OP *k;
eb209983 7811 int descending;
350de78d 7812 GV *gv;
770526c1 7813 const char *gvname;
7918f24d
NC		 7814
7815 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7816
9c007264
JH		 7817 if (!(o->op_flags & OPf_STACKED))
7818 return;
fafc274c
NC		 7819 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7820 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 7821 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 7822 if (kid->op_type != OP_SCOPE)
7823 return;
7824 kid = kLISTOP->op_last; /* get past scope */
7825 switch(kid->op_type) {
7826 case OP_NCMP:
7827 case OP_I_NCMP:
7828 case OP_SCMP:
7829 break;
7830 default:
7831 return;
7832 }
7833 k = kid; /* remember this node*/
7834 if (kBINOP->op_first->op_type != OP_RV2SV)
7835 return;
7836 kid = kBINOP->op_first; /* get past cmp */
7837 if (kUNOP->op_first->op_type != OP_GV)
7838 return;
7839 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7840 gv = kGVOP_gv;
350de78d 7841 if (GvSTASH(gv) != PL_curstash)
9c007264 7842 return;
770526c1
NC		 7843 gvname = GvNAME(gv);
7844 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 7845 descending = 0;
770526c1 7846 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 7847 descending = 1;
9c007264
JH		 7848 else
7849 return;
eb209983 7850
9c007264
JH		 7851 kid = k; /* back to cmp */
7852 if (kBINOP->op_last->op_type != OP_RV2SV)
7853 return;
7854 kid = kBINOP->op_last; /* down to 2nd arg */
7855 if (kUNOP->op_first->op_type != OP_GV)
7856 return;
7857 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7858 gv = kGVOP_gv;
770526c1
NC		 7859 if (GvSTASH(gv) != PL_curstash)
7860 return;
7861 gvname = GvNAME(gv);
7862 if ( descending
7863 ? !(*gvname == 'a' && gvname[1] == '\0')
7864 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 7865 return;
7866 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 7867 if (descending)
7868 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 7869 if (k->op_type == OP_NCMP)
7870 o->op_private |= OPpSORT_NUMERIC;
7871 if (k->op_type == OP_I_NCMP)
7872 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 7873 kid = cLISTOPo->op_first->op_sibling;
7874 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 7875#ifdef PERL_MAD
7876 op_getmad(kid,o,'S'); /* then delete it */
7877#else
e507f050 7878 op_free(kid); /* then delete it */
eb8433b7 7879#endif
9c007264 7880}
79072805
LW		 7881
7882OP *
cea2e8a9 7883Perl_ck_split(pTHX_ OP *o)
79072805 7884{
27da23d5 7885 dVAR;
79072805 7886 register OP *kid;
aeea060c 7887
7918f24d
NC		 7888 PERL_ARGS_ASSERT_CK_SPLIT;
7889
11343788
MB		 7890 if (o->op_flags & OPf_STACKED)
7891 return no_fh_allowed(o);
79072805 7892
11343788 7893 kid = cLISTOPo->op_first;
8990e307 7894 if (kid->op_type != OP_NULL)
cea2e8a9 7895 Perl_croak(aTHX_ "panic: ck_split");
8990e307 7896 kid = kid->op_sibling;
11343788
MB		 7897 op_free(cLISTOPo->op_first);
7898 cLISTOPo->op_first = kid;
85e6fe83 7899 if (!kid) {
396482e1 7900 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 7901 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 7902 }
79072805 7903
de4bf5b3 7904 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 7905 OP * const sibl = kid->op_sibling;
463ee0b2 7906 kid->op_sibling = 0;
131b3ad0 7907 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 7908 if (cLISTOPo->op_first == cLISTOPo->op_last)
7909 cLISTOPo->op_last = kid;
7910 cLISTOPo->op_first = kid;
79072805
LW		 7911 kid->op_sibling = sibl;
7912 }
7913
7914 kid->op_type = OP_PUSHRE;
22c35a8c 7915 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 7916 scalar(kid);
041457d9 7917 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
f34840d8
MJD		 7918 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7919 "Use of /g modifier is meaningless in split");
7920 }
79072805
LW		 7921
7922 if (!kid->op_sibling)
54b9620d 7923 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 7924
7925 kid = kid->op_sibling;
7926 scalar(kid);
7927
7928 if (!kid->op_sibling)
11343788 7929 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
ce3e5c45 7930 assert(kid->op_sibling);
79072805
LW		 7931
7932 kid = kid->op_sibling;
7933 scalar(kid);
7934
7935 if (kid->op_sibling)
53e06cf0 7936 return too_many_arguments(o,OP_DESC(o));
79072805 7937
11343788 7938 return o;
79072805
LW		 7939}
7940
7941OP *
1c846c1f 7942Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 7943{
551405c4 7944 const OP * const kid = cLISTOPo->op_first->op_sibling;
7918f24d
NC		 7945
7946 PERL_ARGS_ASSERT_CK_JOIN;
7947
041457d9
DM		 7948 if (kid && kid->op_type == OP_MATCH) {
7949 if (ckWARN(WARN_SYNTAX)) {
6867be6d 7950 const REGEXP *re = PM_GETRE(kPMOP);
d2c6dc5e 7951 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
220fc49f 7952 const STRLEN len = re ? RX_PRELEN(re) : 6;
9014280d 7953 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
bcdf7404 7954 "/%.*s/ should probably be written as \"%.*s\"",
d83b45b8 7955 (int)len, pmstr, (int)len, pmstr);
eb6e2d6f
GS		 7956 }
7957 }
7958 return ck_fun(o);
7959}
7960
7961OP *
cea2e8a9 7962Perl_ck_subr(pTHX_ OP *o)
79072805 7963{
97aff369 7964 dVAR;
11343788
MB		 7965 OP *prev = ((cUNOPo->op_first->op_sibling)
7966 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7967 OP *o2 = prev->op_sibling;
4633a7c4 7968 OP *cvop;
a0751766 7969 const char *proto = NULL;
cbf82dd0 7970 const char *proto_end = NULL;
c445ea15
AL		 7971 CV *cv = NULL;
7972 GV *namegv = NULL;
4633a7c4
LW		 7973 int optional = 0;
7974 I32 arg = 0;
5b794e05 7975 I32 contextclass = 0;
d3fcec1f 7976 const char *e = NULL;
0723351e 7977 bool delete_op = 0;
4633a7c4 7978
7918f24d
NC		 7979 PERL_ARGS_ASSERT_CK_SUBR;
7980
d3011074 7981 o->op_private |= OPpENTERSUB_HASTARG;
11343788 7982 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 7983 if (cvop->op_type == OP_RV2CV) {
7984 SVOP* tmpop;
11343788 7985 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 7986 op_null(cvop); /* disable rv2cv */
4633a7c4 7987 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 7988 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 7989 GV *gv = cGVOPx_gv(tmpop);
350de78d 7990 cv = GvCVu(gv);
76cd736e
GS		 7991 if (!cv)
7992 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 7993 else {
7994 if (SvPOK(cv)) {
cbf82dd0 7995 STRLEN len;
06492da6 7996 namegv = CvANON(cv) ? gv : CvGV(cv);
ad64d0ec 7997 proto = SvPV(MUTABLE_SV(cv), len);
cbf82dd0 7998 proto_end = proto + len;
06492da6 7999 }
46fc3d4c 8000 }
4633a7c4
LW		 8001 }
8002 }
f5d5a27c 8003 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 8004 if (o2->op_type == OP_CONST)
8005 o2->op_private &= ~OPpCONST_STRICT;
58a40671 8006 else if (o2->op_type == OP_LIST) {
5f66b61c
AL		 8007 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8008 if (sib && sib->op_type == OP_CONST)
8009 sib->op_private &= ~OPpCONST_STRICT;
58a40671 8010 }
7a52d87a 8011 }
3280af22
NIS		 8012 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8013 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 8014 o->op_private |= OPpENTERSUB_DB;
8015 while (o2 != cvop) {
eb8433b7 8016 OP* o3;
9fc012f4
GG		 8017 if (PL_madskills && o2->op_type == OP_STUB) {
8018 o2 = o2->op_sibling;
8019 continue;
8020 }
eb8433b7
NC		 8021 if (PL_madskills && o2->op_type == OP_NULL)
8022 o3 = ((UNOP*)o2)->op_first;
8023 else
8024 o3 = o2;
4633a7c4 8025 if (proto) {
cbf82dd0 8026 if (proto >= proto_end)
5dc0d613 8027 return too_many_arguments(o, gv_ename(namegv));
cbf82dd0
NC		 8028
8029 switch (*proto) {
4633a7c4
LW		 8030 case ';':
8031 optional = 1;
8032 proto++;
8033 continue;
b13fd70a 8034 case '_':
f00d1d61 8035 /* _ must be at the end */
cb40c25d 8036 if (proto[1] && proto[1] != ';')
f00d1d61 8037 goto oops;
4633a7c4
LW		 8038 case '$':
8039 proto++;
8040 arg++;
11343788 8041 scalar(o2);
4633a7c4
LW		 8042 break;
8043 case '%':
8044 case '@':
11343788 8045 list(o2);
4633a7c4
LW		 8046 arg++;
8047 break;
8048 case '&':
8049 proto++;
8050 arg++;
eb8433b7 8051 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
75fc29ea 8052 bad_type(arg,
666ea192
JH		 8053 arg == 1 ? "block or sub {}" : "sub {}",
8054 gv_ename(namegv), o3);
4633a7c4
LW		 8055 break;
8056 case '*':
2ba6ecf4 8057 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 8058 proto++;
8059 arg++;
eb8433b7 8060 if (o3->op_type == OP_RV2GV)
2ba6ecf4 8061 goto wrapref; /* autoconvert GLOB -> GLOBref */
eb8433b7
NC		 8062 else if (o3->op_type == OP_CONST)
8063 o3->op_private &= ~OPpCONST_STRICT;
8064 else if (o3->op_type == OP_ENTERSUB) {
9675f7ac 8065 /* accidental subroutine, revert to bareword */
eb8433b7 8066 OP *gvop = ((UNOP*)o3)->op_first;
9675f7ac
GS		 8067 if (gvop && gvop->op_type == OP_NULL) {
8068 gvop = ((UNOP*)gvop)->op_first;
8069 if (gvop) {
8070 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8071 ;
8072 if (gvop &&
8073 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8074 (gvop = ((UNOP*)gvop)->op_first) &&
8075 gvop->op_type == OP_GV)
8076 {
551405c4
AL		 8077 GV * const gv = cGVOPx_gv(gvop);
8078 OP * const sibling = o2->op_sibling;
396482e1 8079 SV * const n = newSVpvs("");
eb8433b7 8080#ifdef PERL_MAD
1d866c12 8081 OP * const oldo2 = o2;
eb8433b7 8082#else
9675f7ac 8083 op_free(o2);
eb8433b7 8084#endif
2a797ae2 8085 gv_fullname4(n, gv, "", FALSE);
2692f720 8086 o2 = newSVOP(OP_CONST, 0, n);
eb8433b7 8087 op_getmad(oldo2,o2,'O');
9675f7ac
GS		 8088 prev->op_sibling = o2;
8089 o2->op_sibling = sibling;
8090 }
8091 }
8092 }
8093 }
2ba6ecf4
GS		 8094 scalar(o2);
8095 break;
5b794e05
JH		 8096 case '[': case ']':
8097 goto oops;
8098 break;
4633a7c4
LW		 8099 case '\\':
8100 proto++;
8101 arg++;
5b794e05 8102 again:
4633a7c4 8103 switch (*proto++) {
5b794e05
JH		 8104 case '[':
8105 if (contextclass++ == 0) {
841d93c8 8106 e = strchr(proto, ']');
5b794e05
JH		 8107 if (!e || e == proto)
8108 goto oops;
8109 }
8110 else
8111 goto oops;
8112 goto again;
8113 break;
8114 case ']':
466bafcd 8115 if (contextclass) {
a0751766
NC		 8116 const char *p = proto;
8117 const char *const end = proto;
466bafcd 8118 contextclass = 0;
47127b64 8119 while (*--p != '[') {}
a0751766
NC		 8120 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8121 (int)(end - p), p),
8122 gv_ename(namegv), o3);
466bafcd 8123 } else
5b794e05
JH		 8124 goto oops;
8125 break;
4633a7c4 8126 case '*':
eb8433b7 8127 if (o3->op_type == OP_RV2GV)
5b794e05
JH		 8128 goto wrapref;
8129 if (!contextclass)
eb8433b7 8130 bad_type(arg, "symbol", gv_ename(namegv), o3);
5b794e05 8131 break;
4633a7c4 8132 case '&':
eb8433b7 8133 if (o3->op_type == OP_ENTERSUB)
5b794e05
JH		 8134 goto wrapref;
8135 if (!contextclass)
eb8433b7
NC		 8136 bad_type(arg, "subroutine entry", gv_ename(namegv),
8137 o3);
5b794e05 8138 break;
4633a7c4 8139 case '$':
eb8433b7
NC		 8140 if (o3->op_type == OP_RV2SV ||
8141 o3->op_type == OP_PADSV ||
8142 o3->op_type == OP_HELEM ||
5b9081af 8143 o3->op_type == OP_AELEM)
5b794e05
JH		 8144 goto wrapref;
8145 if (!contextclass)
eb8433b7 8146 bad_type(arg, "scalar", gv_ename(namegv), o3);
5b794e05 8147 break;
4633a7c4 8148 case '@':
eb8433b7
NC		 8149 if (o3->op_type == OP_RV2AV ||
8150 o3->op_type == OP_PADAV)
5b794e05
JH		 8151 goto wrapref;
8152 if (!contextclass)
eb8433b7 8153 bad_type(arg, "array", gv_ename(namegv), o3);
5b794e05 8154 break;
4633a7c4 8155 case '%':
eb8433b7
NC		 8156 if (o3->op_type == OP_RV2HV ||
8157 o3->op_type == OP_PADHV)
5b794e05
JH		 8158 goto wrapref;
8159 if (!contextclass)
eb8433b7 8160 bad_type(arg, "hash", gv_ename(namegv), o3);
5b794e05
JH		 8161 break;
8162 wrapref:
4633a7c4 8163 {
551405c4
AL		 8164 OP* const kid = o2;
8165 OP* const sib = kid->op_sibling;
4633a7c4 8166 kid->op_sibling = 0;
6fa846a0
GS		 8167 o2 = newUNOP(OP_REFGEN, 0, kid);
8168 o2->op_sibling = sib;
e858de61 8169 prev->op_sibling = o2;
4633a7c4 8170 }
841d93c8 8171 if (contextclass && e) {
5b794e05
JH		 8172 proto = e + 1;
8173 contextclass = 0;
8174 }
4633a7c4
LW		 8175 break;
8176 default: goto oops;
8177 }
5b794e05
JH		 8178 if (contextclass)
8179 goto again;
4633a7c4 8180 break;
b1cb66bf 8181 case ' ':
8182 proto++;
8183 continue;
4633a7c4
LW		 8184 default:
8185 oops:
35c1215d 8186 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
be2597df 8187 gv_ename(namegv), SVfARG(cv));
4633a7c4
LW		 8188 }
8189 }
8190 else
11343788
MB		 8191 list(o2);
8192 mod(o2, OP_ENTERSUB);
8193 prev = o2;
8194 o2 = o2->op_sibling;
551405c4 8195 } /* while */
236b555a
RGS		 8196 if (o2 == cvop && proto && *proto == '_') {
8197 /* generate an access to $_ */
8198 o2 = newDEFSVOP();
8199 o2->op_sibling = prev->op_sibling;
8200 prev->op_sibling = o2; /* instead of cvop */
8201 }
cbf82dd0 8202 if (proto && !optional && proto_end > proto &&
236b555a 8203 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
5dc0d613 8204 return too_few_arguments(o, gv_ename(namegv));
0723351e 8205 if(delete_op) {
eb8433b7 8206#ifdef PERL_MAD
1d866c12 8207 OP * const oldo = o;
eb8433b7 8208#else
06492da6 8209 op_free(o);
eb8433b7 8210#endif
06492da6 8211 o=newSVOP(OP_CONST, 0, newSViv(0));
eb8433b7 8212 op_getmad(oldo,o,'O');
06492da6 8213 }
11343788 8214 return o;
79072805
LW		 8215}
8216
8217OP *
cea2e8a9 8218Perl_ck_svconst(pTHX_ OP *o)
8990e307 8219{
7918f24d 8220 PERL_ARGS_ASSERT_CK_SVCONST;
96a5add6 8221 PERL_UNUSED_CONTEXT;
11343788
MB		 8222 SvREADONLY_on(cSVOPo->op_sv);
8223 return o;
8990e307
LW		 8224}
8225
8226OP *
d4ac975e
GA		 8227Perl_ck_chdir(pTHX_ OP *o)
8228{
8229 if (o->op_flags & OPf_KIDS) {
1496a290 8230 SVOP * const kid = (SVOP*)cUNOPo->op_first;
d4ac975e
GA		 8231
8232 if (kid && kid->op_type == OP_CONST &&
8233 (kid->op_private & OPpCONST_BARE))
8234 {
8235 o->op_flags |= OPf_SPECIAL;
8236 kid->op_private &= ~OPpCONST_STRICT;
8237 }
8238 }
8239 return ck_fun(o);
8240}
8241
8242OP *
cea2e8a9 8243Perl_ck_trunc(pTHX_ OP *o)
79072805 8244{
7918f24d
NC		 8245 PERL_ARGS_ASSERT_CK_TRUNC;
8246
11343788
MB		 8247 if (o->op_flags & OPf_KIDS) {
8248 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 8249
a0d0e21e
LW		 8250 if (kid->op_type == OP_NULL)
8251 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 8252 if (kid && kid->op_type == OP_CONST &&
8253 (kid->op_private & OPpCONST_BARE))
8254 {
11343788 8255 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 8256 kid->op_private &= ~OPpCONST_STRICT;
8257 }
79072805 8258 }
11343788 8259 return ck_fun(o);
79072805
LW		 8260}
8261
35fba0d9 8262OP *
bab9c0ac
RGS		 8263Perl_ck_unpack(pTHX_ OP *o)
8264{
8265 OP *kid = cLISTOPo->op_first;
7918f24d
NC		 8266
8267 PERL_ARGS_ASSERT_CK_UNPACK;
8268
bab9c0ac
RGS		 8269 if (kid->op_sibling) {
8270 kid = kid->op_sibling;
8271 if (!kid->op_sibling)
8272 kid->op_sibling = newDEFSVOP();
8273 }
8274 return ck_fun(o);
8275}
8276
8277OP *
35fba0d9
RG		 8278Perl_ck_substr(pTHX_ OP *o)
8279{
7918f24d
NC		 8280 PERL_ARGS_ASSERT_CK_SUBSTR;
8281
35fba0d9 8282 o = ck_fun(o);
1d866c12 8283 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 8284 OP *kid = cLISTOPo->op_first;
8285
8286 if (kid->op_type == OP_NULL)
8287 kid = kid->op_sibling;
8288 if (kid)
8289 kid->op_flags |= OPf_MOD;
8290
8291 }
8292 return o;
8293}
8294
878d132a
NC		 8295OP *
8296Perl_ck_each(pTHX_ OP *o)
8297{
d75c0fe7 8298 dVAR;
878d132a
NC		 8299 OP *kid = cLISTOPo->op_first;
8300
7918f24d
NC		 8301 PERL_ARGS_ASSERT_CK_EACH;
8302
878d132a
NC		 8303 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8304 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8305 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8306 o->op_type = new_type;
8307 o->op_ppaddr = PL_ppaddr[new_type];
8308 }
8309 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8310 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8311 )) {
8312 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8313 return o;
8314 }
8315 return ck_fun(o);
8316}
8317
61b743bb
DM		 8318/* A peephole optimizer. We visit the ops in the order they're to execute.
8319 * See the comments at the top of this file for more details about when
8320 * peep() is called */
463ee0b2 8321
79072805 8322void
864dbfa3 8323Perl_peep(pTHX_ register OP *o)
79072805 8324{
27da23d5 8325 dVAR;
c445ea15 8326 register OP* oldop = NULL;
2d8e6c8d 8327
2814eb74 8328 if (!o || o->op_opt)
79072805 8329 return;
a0d0e21e 8330 ENTER;
462e5cf6 8331 SAVEOP();
7766f137 8332 SAVEVPTR(PL_curcop);
a0d0e21e 8333 for (; o; o = o->op_next) {
2814eb74 8334 if (o->op_opt)
a0d0e21e 8335 break;
6d7dd4a5
NC		 8336 /* By default, this op has now been optimised. A couple of cases below
8337 clear this again. */
8338 o->op_opt = 1;
533c011a 8339 PL_op = o;
a0d0e21e
LW		 8340 switch (o->op_type) {
8341 case OP_NEXTSTATE:
8342 case OP_DBSTATE:
3280af22 8343 PL_curcop = ((COP*)o); /* for warnings */
a0d0e21e
LW		 8344 break;
8345
a0d0e21e 8346 case OP_CONST:
7a52d87a
GS		 8347 if (cSVOPo->op_private & OPpCONST_STRICT)
8348 no_bareword_allowed(o);
7766f137 8349#ifdef USE_ITHREADS
996c9baa 8350 case OP_HINTSEVAL:
3848b962 8351 case OP_METHOD_NAMED:
7766f137
GS		 8352 /* Relocate sv to the pad for thread safety.
8353 * Despite being a "constant", the SV is written to,
8354 * for reference counts, sv_upgrade() etc. */
8355 if (cSVOP->op_sv) {
6867be6d 8356 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
996c9baa 8357 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 8358 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 8359 * some pad, so make a copy. */
dd2155a4
DM		 8360 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8361 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 8362 SvREFCNT_dec(cSVOPo->op_sv);
8363 }
996c9baa 8364 else if (o->op_type != OP_METHOD_NAMED
052ca17e
NC		 8365 && cSVOPo->op_sv == &PL_sv_undef) {
8366 /* PL_sv_undef is hack - it's unsafe to store it in the
8367 AV that is the pad, because av_fetch treats values of
8368 PL_sv_undef as a "free" AV entry and will merrily
8369 replace them with a new SV, causing pad_alloc to think
8370 that this pad slot is free. (When, clearly, it is not)
8371 */
8372 SvOK_off(PAD_SVl(ix));
8373 SvPADTMP_on(PAD_SVl(ix));
8374 SvREADONLY_on(PAD_SVl(ix));
8375 }
6a7129a1 8376 else {
dd2155a4 8377 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 8378 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 8379 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 8380 /* XXX I don't know how this isn't readonly already. */
dd2155a4 8381 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 8382 }
a0714e2c 8383 cSVOPo->op_sv = NULL;
7766f137
GS		 8384 o->op_targ = ix;
8385 }
8386#endif
07447971
GS		 8387 break;
8388
df91b2c5
AE		 8389 case OP_CONCAT:
8390 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8391 if (o->op_next->op_private & OPpTARGET_MY) {
8392 if (o->op_flags & OPf_STACKED) /* chained concats */
a6aa0b75 8393 break; /* ignore_optimization */
df91b2c5
AE		 8394 else {
8395 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8396 o->op_targ = o->op_next->op_targ;
8397 o->op_next->op_targ = 0;
8398 o->op_private |= OPpTARGET_MY;
8399 }
8400 }
8401 op_null(o->op_next);
8402 }
df91b2c5 8403 break;
6d7dd4a5
NC		 8404 case OP_STUB:
8405 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8406 break; /* Scalar stub must produce undef. List stub is noop */
8407 }
8408 goto nothin;
79072805 8409 case OP_NULL:
acb36ea4 8410 if (o->op_targ == OP_NEXTSTATE
5edb5b2a 8411 || o->op_targ == OP_DBSTATE)
acb36ea4 8412 {
3280af22 8413 PL_curcop = ((COP*)o);
acb36ea4 8414 }
dad75012
AMS		 8415 /* XXX: We avoid setting op_seq here to prevent later calls
8416 to peep() from mistakenly concluding that optimisation
8417 has already occurred. This doesn't fix the real problem,
8418 though (See 20010220.007). AMS 20010719 */
2814eb74 8419 /* op_seq functionality is now replaced by op_opt */
6d7dd4a5 8420 o->op_opt = 0;
f46f2f82 8421 /* FALL THROUGH */
79072805 8422 case OP_SCALAR:
93a17b20 8423 case OP_LINESEQ:
463ee0b2 8424 case OP_SCOPE:
6d7dd4a5 8425 nothin:
a0d0e21e
LW		 8426 if (oldop && o->op_next) {
8427 oldop->op_next = o->op_next;
6d7dd4a5 8428 o->op_opt = 0;
79072805
LW		 8429 continue;
8430 }
79072805
LW		 8431 break;
8432
6a077020 8433 case OP_PADAV:
79072805 8434 case OP_GV:
6a077020 8435 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 8436 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 8437 o->op_next : o->op_next->op_next;
a0d0e21e 8438 IV i;
f9dc862f 8439 if (pop && pop->op_type == OP_CONST &&
af5acbb4 8440 ((PL_op = pop->op_next)) &&
8990e307 8441 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 8442 !(pop->op_next->op_private &
78f9721b 8443 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
fc15ae8f 8444 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
a0d0e21e 8445 <= 255 &&
8990e307
LW		 8446 i >= 0)
8447 {
350de78d 8448 GV *gv;
af5acbb4
DM		 8449 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8450 no_bareword_allowed(pop);
6a077020
DM		 8451 if (o->op_type == OP_GV)
8452 op_null(o->op_next);
93c66552
DM		 8453 op_null(pop->op_next);
8454 op_null(pop);
a0d0e21e
LW		 8455 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8456 o->op_next = pop->op_next->op_next;
22c35a8c 8457 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 8458 o->op_private = (U8)i;
6a077020
DM		 8459 if (o->op_type == OP_GV) {
8460 gv = cGVOPo_gv;
8461 GvAVn(gv);
8462 }
8463 else
8464 o->op_flags |= OPf_SPECIAL;
8465 o->op_type = OP_AELEMFAST;
8466 }
6a077020
DM		 8467 break;
8468 }
8469
8470 if (o->op_next->op_type == OP_RV2SV) {
8471 if (!(o->op_next->op_private & OPpDEREF)) {
8472 op_null(o->op_next);
8473 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8474 | OPpOUR_INTRO);
8475 o->op_next = o->op_next->op_next;
8476 o->op_type = OP_GVSV;
8477 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 8478 }
79072805 8479 }
e476b1b5 8480 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
551405c4 8481 GV * const gv = cGVOPo_gv;
b15aece3 8482 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 8483 /* XXX could check prototype here instead of just carping */
551405c4 8484 SV * const sv = sv_newmortal();
bd61b366 8485 gv_efullname3(sv, gv, NULL);
9014280d 8486 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d 8487 "%"SVf"() called too early to check prototype",
be2597df 8488 SVfARG(sv));
76cd736e
GS		 8489 }
8490 }
89de2904
AMS		 8491 else if (o->op_next->op_type == OP_READLINE
8492 && o->op_next->op_next->op_type == OP_CONCAT
8493 && (o->op_next->op_next->op_flags & OPf_STACKED))
8494 {
d2c45030
AMS		 8495 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8496 o->op_type = OP_RCATLINE;
8497 o->op_flags |= OPf_STACKED;
8498 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 8499 op_null(o->op_next->op_next);
d2c45030 8500 op_null(o->op_next);
89de2904 8501 }
76cd736e 8502
79072805
LW		 8503 break;
8504
a0d0e21e 8505 case OP_MAPWHILE:
79072805
LW		 8506 case OP_GREPWHILE:
8507 case OP_AND:
8508 case OP_OR:
c963b151 8509 case OP_DOR:
2c2d71f5
JH		 8510 case OP_ANDASSIGN:
8511 case OP_ORASSIGN:
c963b151 8512 case OP_DORASSIGN:
1a67a97c
SM		 8513 case OP_COND_EXPR:
8514 case OP_RANGE:
c5917253 8515 case OP_ONCE:
fd4d1407
IZ		 8516 while (cLOGOP->op_other->op_type == OP_NULL)
8517 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 8518 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 8519 break;
8520
79072805 8521 case OP_ENTERLOOP:
9c2ca71a 8522 case OP_ENTERITER:
58cccf98
SM		 8523 while (cLOOP->op_redoop->op_type == OP_NULL)
8524 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 8525 peep(cLOOP->op_redoop);
58cccf98
SM		 8526 while (cLOOP->op_nextop->op_type == OP_NULL)
8527 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 8528 peep(cLOOP->op_nextop);
58cccf98
SM		 8529 while (cLOOP->op_lastop->op_type == OP_NULL)
8530 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 8531 peep(cLOOP->op_lastop);
8532 break;
8533
79072805 8534 case OP_SUBST:
29f2e912
NC		 8535 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8536 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8537 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8538 cPMOP->op_pmstashstartu.op_pmreplstart
8539 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8540 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
79072805
LW		 8541 break;
8542
a0d0e21e 8543 case OP_EXEC:
041457d9
DM		 8544 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8545 && ckWARN(WARN_SYNTAX))
8546 {
1496a290
AL		 8547 if (o->op_next->op_sibling) {
8548 const OPCODE type = o->op_next->op_sibling->op_type;
8549 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8550 const line_t oldline = CopLINE(PL_curcop);
8551 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8552 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8553 "Statement unlikely to be reached");
8554 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8555 "\t(Maybe you meant system() when you said exec()?)\n");
8556 CopLINE_set(PL_curcop, oldline);
8557 }
a0d0e21e
LW		 8558 }
8559 }
8560 break;
b2ffa427 8561
c750a3ec 8562 case OP_HELEM: {
e75d1f10 8563 UNOP *rop;
6d822dc4 8564 SV *lexname;
e75d1f10 8565 GV **fields;
6d822dc4 8566 SV **svp, *sv;
d5263905 8567 const char *key = NULL;
c750a3ec 8568 STRLEN keylen;
b2ffa427 8569
1c846c1f 8570 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 8571 break;
1c846c1f
NIS		 8572
8573 /* Make the CONST have a shared SV */
8574 svp = cSVOPx_svp(((BINOP*)o)->op_last);
38bb37b9 8575 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
d5263905 8576 key = SvPV_const(sv, keylen);
25716404 8577 lexname = newSVpvn_share(key,
bb7a0f54 8578 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
25716404 8579 0);
1c846c1f
NIS		 8580 SvREFCNT_dec(sv);
8581 *svp = lexname;
8582 }
e75d1f10
RD		 8583
8584 if ((o->op_private & (OPpLVAL_INTRO)))
8585 break;
8586
8587 rop = (UNOP*)((BINOP*)o)->op_first;
8588 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8589 break;
8590 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
00b1698f 8591 if (!SvPAD_TYPED(lexname))
e75d1f10 8592 break;
a4fc7abc 8593 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 8594 if (!fields || !GvHV(*fields))
8595 break;
93524f2b 8596 key = SvPV_const(*svp, keylen);
e75d1f10 8597 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 8598 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 8599 {
8600 Perl_croak(aTHX_ "No such class field \"%s\" "
8601 "in variable %s of type %s",
93524f2b 8602 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8603 }
8604
6d822dc4
MS		 8605 break;
8606 }
c750a3ec 8607
e75d1f10
RD		 8608 case OP_HSLICE: {
8609 UNOP *rop;
8610 SV *lexname;
8611 GV **fields;
8612 SV **svp;
93524f2b 8613 const char *key;
e75d1f10
RD		 8614 STRLEN keylen;
8615 SVOP *first_key_op, *key_op;
8616
8617 if ((o->op_private & (OPpLVAL_INTRO))
8618 /* I bet there's always a pushmark... */
8619 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8620 /* hmmm, no optimization if list contains only one key. */
8621 break;
8622 rop = (UNOP*)((LISTOP*)o)->op_last;
8623 if (rop->op_type != OP_RV2HV)
8624 break;
8625 if (rop->op_first->op_type == OP_PADSV)
8626 /* @$hash{qw(keys here)} */
8627 rop = (UNOP*)rop->op_first;
8628 else {
8629 /* @{$hash}{qw(keys here)} */
8630 if (rop->op_first->op_type == OP_SCOPE
8631 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8632 {
8633 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8634 }
8635 else
8636 break;
8637 }
8638
8639 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
00b1698f 8640 if (!SvPAD_TYPED(lexname))
e75d1f10 8641 break;
a4fc7abc 8642 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 8643 if (!fields || !GvHV(*fields))
8644 break;
8645 /* Again guessing that the pushmark can be jumped over.... */
8646 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8647 ->op_first->op_sibling;
8648 for (key_op = first_key_op; key_op;
8649 key_op = (SVOP*)key_op->op_sibling) {
8650 if (key_op->op_type != OP_CONST)
8651 continue;
8652 svp = cSVOPx_svp(key_op);
93524f2b 8653 key = SvPV_const(*svp, keylen);
e75d1f10 8654 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 8655 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 8656 {
8657 Perl_croak(aTHX_ "No such class field \"%s\" "
8658 "in variable %s of type %s",
bfcb3514 8659 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8660 }
8661 }
8662 break;
8663 }
8664
fe1bc4cf 8665 case OP_SORT: {
fe1bc4cf 8666 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
551405c4 8667 OP *oleft;
fe1bc4cf
DM		 8668 OP *o2;
8669
fe1bc4cf 8670 /* check that RHS of sort is a single plain array */
551405c4 8671 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 8672 if (!oright || oright->op_type != OP_PUSHMARK)
8673 break;
471178c0
NC		 8674
8675 /* reverse sort ... can be optimised. */
8676 if (!cUNOPo->op_sibling) {
8677 /* Nothing follows us on the list. */
551405c4 8678 OP * const reverse = o->op_next;
471178c0
NC		 8679
8680 if (reverse->op_type == OP_REVERSE &&
8681 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 8682 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 8683 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8684 && (cUNOPx(pushmark)->op_sibling == o)) {
8685 /* reverse -> pushmark -> sort */
8686 o->op_private |= OPpSORT_REVERSE;
8687 op_null(reverse);
8688 pushmark->op_next = oright->op_next;
8689 op_null(oright);
8690 }
8691 }
8692 }
8693
8694 /* make @a = sort @a act in-place */
8695
fe1bc4cf
DM		 8696 oright = cUNOPx(oright)->op_sibling;
8697 if (!oright)
8698 break;
8699 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8700 oright = cUNOPx(oright)->op_sibling;
8701 }
8702
8703 if (!oright ||
8704 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8705 || oright->op_next != o
8706 || (oright->op_private & OPpLVAL_INTRO)
8707 )
8708 break;
8709
8710 /* o2 follows the chain of op_nexts through the LHS of the
8711 * assign (if any) to the aassign op itself */
8712 o2 = o->op_next;
8713 if (!o2 || o2->op_type != OP_NULL)
8714 break;
8715 o2 = o2->op_next;
8716 if (!o2 || o2->op_type != OP_PUSHMARK)
8717 break;
8718 o2 = o2->op_next;
8719 if (o2 && o2->op_type == OP_GV)
8720 o2 = o2->op_next;
8721 if (!o2
8722 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8723 || (o2->op_private & OPpLVAL_INTRO)
8724 )
8725 break;
8726 oleft = o2;
8727 o2 = o2->op_next;
8728 if (!o2 || o2->op_type != OP_NULL)
8729 break;
8730 o2 = o2->op_next;
8731 if (!o2 || o2->op_type != OP_AASSIGN
8732 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8733 break;
8734
db7511db
DM		 8735 /* check that the sort is the first arg on RHS of assign */
8736
8737 o2 = cUNOPx(o2)->op_first;
8738 if (!o2 || o2->op_type != OP_NULL)
8739 break;
8740 o2 = cUNOPx(o2)->op_first;
8741 if (!o2 || o2->op_type != OP_PUSHMARK)
8742 break;
8743 if (o2->op_sibling != o)
8744 break;
8745
fe1bc4cf
DM		 8746 /* check the array is the same on both sides */
8747 if (oleft->op_type == OP_RV2AV) {
8748 if (oright->op_type != OP_RV2AV
8749 || !cUNOPx(oright)->op_first
8750 || cUNOPx(oright)->op_first->op_type != OP_GV
8751 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8752 cGVOPx_gv(cUNOPx(oright)->op_first)
8753 )
8754 break;
8755 }
8756 else if (oright->op_type != OP_PADAV
8757 || oright->op_targ != oleft->op_targ
8758 )
8759 break;
8760
8761 /* transfer MODishness etc from LHS arg to RHS arg */
8762 oright->op_flags = oleft->op_flags;
8763 o->op_private |= OPpSORT_INPLACE;
8764
8765 /* excise push->gv->rv2av->null->aassign */
8766 o2 = o->op_next->op_next;
8767 op_null(o2); /* PUSHMARK */
8768 o2 = o2->op_next;
8769 if (o2->op_type == OP_GV) {
8770 op_null(o2); /* GV */
8771 o2 = o2->op_next;
8772 }
8773 op_null(o2); /* RV2AV or PADAV */
8774 o2 = o2->op_next->op_next;
8775 op_null(o2); /* AASSIGN */
8776
8777 o->op_next = o2->op_next;
8778
8779 break;
8780 }
ef3e5ea9
NC		 8781
8782 case OP_REVERSE: {
e682d7b7 8783 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 8784 OP *gvop = NULL;
ef3e5ea9 8785 LISTOP *enter, *exlist;
ef3e5ea9
NC		 8786
8787 enter = (LISTOP *) o->op_next;
8788 if (!enter)
8789 break;
8790 if (enter->op_type == OP_NULL) {
8791 enter = (LISTOP *) enter->op_next;
8792 if (!enter)
8793 break;
8794 }
d46f46af
NC		 8795 /* for $a (...) will have OP_GV then OP_RV2GV here.
8796 for (...) just has an OP_GV. */
ce335f37
NC		 8797 if (enter->op_type == OP_GV) {
8798 gvop = (OP *) enter;
8799 enter = (LISTOP *) enter->op_next;
8800 if (!enter)
8801 break;
d46f46af
NC		 8802 if (enter->op_type == OP_RV2GV) {
8803 enter = (LISTOP *) enter->op_next;
8804 if (!enter)
ce335f37 8805 break;
d46f46af 8806 }
ce335f37
NC		 8807 }
8808
ef3e5ea9
NC		 8809 if (enter->op_type != OP_ENTERITER)
8810 break;
8811
8812 iter = enter->op_next;
8813 if (!iter || iter->op_type != OP_ITER)
8814 break;
8815
ce335f37
NC		 8816 expushmark = enter->op_first;
8817 if (!expushmark || expushmark->op_type != OP_NULL
8818 || expushmark->op_targ != OP_PUSHMARK)
8819 break;
8820
8821 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 8822 if (!exlist || exlist->op_type != OP_NULL
8823 || exlist->op_targ != OP_LIST)
8824 break;
8825
8826 if (exlist->op_last != o) {
8827 /* Mmm. Was expecting to point back to this op. */
8828 break;
8829 }
8830 theirmark = exlist->op_first;
8831 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8832 break;
8833
c491ecac 8834 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 8835 /* There's something between the mark and the reverse, eg
8836 for (1, reverse (...))
8837 so no go. */
8838 break;
8839 }
8840
c491ecac
NC		 8841 ourmark = ((LISTOP *)o)->op_first;
8842 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8843 break;
8844
ef3e5ea9
NC		 8845 ourlast = ((LISTOP *)o)->op_last;
8846 if (!ourlast || ourlast->op_next != o)
8847 break;
8848
e682d7b7
NC		 8849 rv2av = ourmark->op_sibling;
8850 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8851 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8852 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8853 /* We're just reversing a single array. */
8854 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8855 enter->op_flags |= OPf_STACKED;
8856 }
8857
ef3e5ea9
NC		 8858 /* We don't have control over who points to theirmark, so sacrifice
8859 ours. */
8860 theirmark->op_next = ourmark->op_next;
8861 theirmark->op_flags = ourmark->op_flags;
ce335f37 8862 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 8863 op_null(ourmark);
8864 op_null(o);
8865 enter->op_private |= OPpITER_REVERSED;
8866 iter->op_private |= OPpITER_REVERSED;
8867
8868 break;
8869 }
e26df76a
NC		 8870
8871 case OP_SASSIGN: {
8872 OP *rv2gv;
8873 UNOP *refgen, *rv2cv;
8874 LISTOP *exlist;
8875
50baa5ea 8876 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
de3370bc
NC		 8877 break;
8878
e26df76a
NC		 8879 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8880 break;
8881
8882 rv2gv = ((BINOP *)o)->op_last;
8883 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8884 break;
8885
8886 refgen = (UNOP *)((BINOP *)o)->op_first;
8887
8888 if (!refgen || refgen->op_type != OP_REFGEN)
8889 break;
8890
8891 exlist = (LISTOP *)refgen->op_first;
8892 if (!exlist || exlist->op_type != OP_NULL
8893 || exlist->op_targ != OP_LIST)
8894 break;
8895
8896 if (exlist->op_first->op_type != OP_PUSHMARK)
8897 break;
8898
8899 rv2cv = (UNOP*)exlist->op_last;
8900
8901 if (rv2cv->op_type != OP_RV2CV)
8902 break;
8903
8904 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8905 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8906 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8907
8908 o->op_private |= OPpASSIGN_CV_TO_GV;
8909 rv2gv->op_private |= OPpDONT_INIT_GV;
8910 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8911
8912 break;
8913 }
8914
fe1bc4cf 8915
0477511c
NC		 8916 case OP_QR:
8917 case OP_MATCH:
29f2e912
NC		 8918 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8919 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8920 }
79072805
LW		 8921 break;
8922 }
a0d0e21e 8923 oldop = o;
79072805 8924 }
a0d0e21e 8925 LEAVE;
79072805 8926}
beab0874 8927
cef6ea9d 8928const char*
1cb0ed9b 8929Perl_custom_op_name(pTHX_ const OP* o)
53e06cf0 8930{
97aff369 8931 dVAR;
e1ec3a88 8932 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8933 SV* keysv;
8934 HE* he;
8935
7918f24d
NC		 8936 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8937
53e06cf0 8938 if (!PL_custom_op_names) /* This probably shouldn't happen */
27da23d5 8939 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 8940
8941 keysv = sv_2mortal(newSViv(index));
8942
8943 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8944 if (!he)
27da23d5 8945 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 8946
8947 return SvPV_nolen(HeVAL(he));
8948}
8949
cef6ea9d 8950const char*
1cb0ed9b 8951Perl_custom_op_desc(pTHX_ const OP* o)
53e06cf0 8952{
97aff369 8953 dVAR;
e1ec3a88 8954 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8955 SV* keysv;
8956 HE* he;
8957
7918f24d
NC		 8958 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8959
53e06cf0 8960 if (!PL_custom_op_descs)
27da23d5 8961 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 8962
8963 keysv = sv_2mortal(newSViv(index));
8964
8965 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8966 if (!he)
27da23d5 8967 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 8968
8969 return SvPV_nolen(HeVAL(he));
8970}
19e8ce8e 8971
beab0874
JT		 8972#include "XSUB.h"
8973
8974/* Efficient sub that returns a constant scalar value. */
8975static void
acfe0abc 8976const_sv_xsub(pTHX_ CV* cv)
beab0874 8977{
97aff369 8978 dVAR;
beab0874 8979 dXSARGS;
99ab892b 8980 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9cbac4c7 8981 if (items != 0) {
6f207bd3 8982 NOOP;
9cbac4c7 8983#if 0
fe13d51d 8984 /* diag_listed_as: SKIPME */
9cbac4c7 8985 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 8986 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 8987#endif
8988 }
99ab892b
NC		 8989 if (!sv) {
8990 XSRETURN(0);
8991 }
9a049f1c 8992 EXTEND(sp, 1);
99ab892b 8993 ST(0) = sv;
beab0874
JT		 8994 XSRETURN(1);
8995}
4946a0fa
NC		 8996
8997/*
8998 * Local variables:
8999 * c-indentation-style: bsd
9000 * c-basic-offset: 4
9001 * indent-tabs-mode: t
9002 * End:
9003 *
37442d52
RGS		 9004 * ex: set ts=8 sts=4 sw=4 noet:
9005 */
Unnamed repository; edit this file 'description' to name the repository.