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