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