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