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