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
move PL_multi_end into the PL_parser struct
[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
2814eb74 426 if (!o || o->op_static)
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 */
551405c4 802 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
5dc0d613 803 || o->op_type == OP_RETURN)
7e363e51 804 {
11343788 805 return o;
7e363e51 806 }
79072805 807
5dc0d613 808 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 809
11343788 810 switch (o->op_type) {
79072805 811 case OP_REPEAT:
11343788 812 scalar(cBINOPo->op_first);
8990e307 813 break;
79072805
LW		 814 case OP_OR:
815 case OP_AND:
816 case OP_COND_EXPR:
11343788 817 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 818 scalar(kid);
79072805 819 break;
a0d0e21e 820 case OP_SPLIT:
11343788 821 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
20e98b0f 822 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
12bcd1a6 823 deprecate_old("implicit split to @_");
a0d0e21e
LW		 824 }
825 /* FALL THROUGH */
79072805 826 case OP_MATCH:
8782bef2 827 case OP_QR:
79072805
LW		 828 case OP_SUBST:
829 case OP_NULL:
8990e307 830 default:
11343788
MB		 831 if (o->op_flags & OPf_KIDS) {
832 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 833 scalar(kid);
834 }
79072805
LW		 835 break;
836 case OP_LEAVE:
837 case OP_LEAVETRY:
5dc0d613 838 kid = cLISTOPo->op_first;
54310121 839 scalar(kid);
155aba94 840 while ((kid = kid->op_sibling)) {
54310121 841 if (kid->op_sibling)
842 scalarvoid(kid);
843 else
844 scalar(kid);
845 }
11206fdd 846 PL_curcop = &PL_compiling;
54310121 847 break;
748a9306 848 case OP_SCOPE:
79072805 849 case OP_LINESEQ:
8990e307 850 case OP_LIST:
11343788 851 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 852 if (kid->op_sibling)
853 scalarvoid(kid);
854 else
855 scalar(kid);
856 }
11206fdd 857 PL_curcop = &PL_compiling;
79072805 858 break;
a801c63c
RGS		 859 case OP_SORT:
860 if (ckWARN(WARN_VOID))
9014280d 861 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 862 }
11343788 863 return o;
79072805
LW		 864}
865
866OP *
864dbfa3 867Perl_scalarvoid(pTHX_ OP *o)
79072805 868{
27da23d5 869 dVAR;
79072805 870 OP *kid;
c445ea15 871 const char* useless = NULL;
8990e307 872 SV* sv;
2ebea0a1
GS		 873 U8 want;
874
eb8433b7
NC		 875 /* trailing mad null ops don't count as "there" for void processing */
876 if (PL_madskills &&
877 o->op_type != OP_NULL &&
878 o->op_sibling &&
879 o->op_sibling->op_type == OP_NULL)
880 {
881 OP *sib;
882 for (sib = o->op_sibling;
883 sib && sib->op_type == OP_NULL;
884 sib = sib->op_sibling) ;
885
886 if (!sib)
887 return o;
888 }
889
acb36ea4
GS		 890 if (o->op_type == OP_NEXTSTATE
891 || o->op_type == OP_SETSTATE
892 || o->op_type == OP_DBSTATE
893 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
894 || o->op_targ == OP_SETSTATE
895 || o->op_targ == OP_DBSTATE)))
2ebea0a1 896 PL_curcop = (COP*)o; /* for warning below */
79072805 897
54310121 898 /* assumes no premature commitment */
2ebea0a1
GS		 899 want = o->op_flags & OPf_WANT;
900 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 901 || o->op_type == OP_RETURN)
7e363e51 902 {
11343788 903 return o;
7e363e51 904 }
79072805 905
b162f9ea 906 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 907 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
908 {
b162f9ea 909 return scalar(o); /* As if inside SASSIGN */
7e363e51 910 }
1c846c1f 911
5dc0d613 912 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 913
11343788 914 switch (o->op_type) {
79072805 915 default:
22c35a8c 916 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 917 break;
36477c24 918 /* FALL THROUGH */
919 case OP_REPEAT:
11343788 920 if (o->op_flags & OPf_STACKED)
8990e307 921 break;
5d82c453
GA		 922 goto func_ops;
923 case OP_SUBSTR:
924 if (o->op_private == 4)
925 break;
8990e307
LW		 926 /* FALL THROUGH */
927 case OP_GVSV:
928 case OP_WANTARRAY:
929 case OP_GV:
930 case OP_PADSV:
931 case OP_PADAV:
932 case OP_PADHV:
933 case OP_PADANY:
934 case OP_AV2ARYLEN:
8990e307 935 case OP_REF:
a0d0e21e
LW		 936 case OP_REFGEN:
937 case OP_SREFGEN:
8990e307
LW		 938 case OP_DEFINED:
939 case OP_HEX:
940 case OP_OCT:
941 case OP_LENGTH:
8990e307
LW		 942 case OP_VEC:
943 case OP_INDEX:
944 case OP_RINDEX:
945 case OP_SPRINTF:
946 case OP_AELEM:
947 case OP_AELEMFAST:
948 case OP_ASLICE:
8990e307
LW		 949 case OP_HELEM:
950 case OP_HSLICE:
951 case OP_UNPACK:
952 case OP_PACK:
8990e307
LW		 953 case OP_JOIN:
954 case OP_LSLICE:
955 case OP_ANONLIST:
956 case OP_ANONHASH:
957 case OP_SORT:
958 case OP_REVERSE:
959 case OP_RANGE:
960 case OP_FLIP:
961 case OP_FLOP:
962 case OP_CALLER:
963 case OP_FILENO:
964 case OP_EOF:
965 case OP_TELL:
966 case OP_GETSOCKNAME:
967 case OP_GETPEERNAME:
968 case OP_READLINK:
969 case OP_TELLDIR:
970 case OP_GETPPID:
971 case OP_GETPGRP:
972 case OP_GETPRIORITY:
973 case OP_TIME:
974 case OP_TMS:
975 case OP_LOCALTIME:
976 case OP_GMTIME:
977 case OP_GHBYNAME:
978 case OP_GHBYADDR:
979 case OP_GHOSTENT:
980 case OP_GNBYNAME:
981 case OP_GNBYADDR:
982 case OP_GNETENT:
983 case OP_GPBYNAME:
984 case OP_GPBYNUMBER:
985 case OP_GPROTOENT:
986 case OP_GSBYNAME:
987 case OP_GSBYPORT:
988 case OP_GSERVENT:
989 case OP_GPWNAM:
990 case OP_GPWUID:
991 case OP_GGRNAM:
992 case OP_GGRGID:
993 case OP_GETLOGIN:
78e1b766 994 case OP_PROTOTYPE:
5d82c453 995 func_ops:
64aac5a9 996 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 997 useless = OP_DESC(o);
8990e307
LW		 998 break;
999
9f82cd5f
YST		 1000 case OP_NOT:
1001 kid = cUNOPo->op_first;
1002 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1003 kid->op_type != OP_TRANS) {
1004 goto func_ops;
1005 }
1006 useless = "negative pattern binding (!~)";
1007 break;
1008
8990e307
LW		 1009 case OP_RV2GV:
1010 case OP_RV2SV:
1011 case OP_RV2AV:
1012 case OP_RV2HV:
192587c2 1013 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1014 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1015 useless = "a variable";
1016 break;
79072805
LW		 1017
1018 case OP_CONST:
7766f137 1019 sv = cSVOPo_sv;
7a52d87a
GS		 1020 if (cSVOPo->op_private & OPpCONST_STRICT)
1021 no_bareword_allowed(o);
1022 else {
d008e5eb
GS		 1023 if (ckWARN(WARN_VOID)) {
1024 useless = "a constant";
2e0ae2d3 1025 if (o->op_private & OPpCONST_ARYBASE)
d4c19fe8 1026 useless = NULL;
e7fec78e 1027 /* don't warn on optimised away booleans, eg
b5a930ec 1028 * use constant Foo, 5; Foo || print; */
e7fec78e 1029 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1030 useless = NULL;
960b4253
MG		 1031 /* the constants 0 and 1 are permitted as they are
1032 conventionally used as dummies in constructs like
1033 1 while some_condition_with_side_effects; */
e7fec78e 1034 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 1035 useless = NULL;
d008e5eb 1036 else if (SvPOK(sv)) {
a52fe3ac
A		 1037 /* perl4's way of mixing documentation and code
1038 (before the invention of POD) was based on a
1039 trick to mix nroff and perl code. The trick was
1040 built upon these three nroff macros being used in
1041 void context. The pink camel has the details in
1042 the script wrapman near page 319. */
6136c704
AL		 1043 const char * const maybe_macro = SvPVX_const(sv);
1044 if (strnEQ(maybe_macro, "di", 2) ||
1045 strnEQ(maybe_macro, "ds", 2) ||
1046 strnEQ(maybe_macro, "ig", 2))
d4c19fe8 1047 useless = NULL;
d008e5eb 1048 }
8990e307
LW		 1049 }
1050 }
93c66552 1051 op_null(o); /* don't execute or even remember it */
79072805
LW		 1052 break;
1053
1054 case OP_POSTINC:
11343788 1055 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1056 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 1057 break;
1058
1059 case OP_POSTDEC:
11343788 1060 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1061 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 1062 break;
1063
679d6c4e
HS		 1064 case OP_I_POSTINC:
1065 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1066 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1067 break;
1068
1069 case OP_I_POSTDEC:
1070 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1071 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1072 break;
1073
79072805
LW		 1074 case OP_OR:
1075 case OP_AND:
c963b151 1076 case OP_DOR:
79072805 1077 case OP_COND_EXPR:
0d863452
RH		 1078 case OP_ENTERGIVEN:
1079 case OP_ENTERWHEN:
11343788 1080 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1081 scalarvoid(kid);
1082 break;
5aabfad6 1083
a0d0e21e 1084 case OP_NULL:
11343788 1085 if (o->op_flags & OPf_STACKED)
a0d0e21e 1086 break;
5aabfad6 1087 /* FALL THROUGH */
2ebea0a1
GS		 1088 case OP_NEXTSTATE:
1089 case OP_DBSTATE:
79072805
LW		 1090 case OP_ENTERTRY:
1091 case OP_ENTER:
11343788 1092 if (!(o->op_flags & OPf_KIDS))
79072805 1093 break;
54310121 1094 /* FALL THROUGH */
463ee0b2 1095 case OP_SCOPE:
79072805
LW		 1096 case OP_LEAVE:
1097 case OP_LEAVETRY:
a0d0e21e 1098 case OP_LEAVELOOP:
79072805 1099 case OP_LINESEQ:
79072805 1100 case OP_LIST:
0d863452
RH		 1101 case OP_LEAVEGIVEN:
1102 case OP_LEAVEWHEN:
11343788 1103 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1104 scalarvoid(kid);
1105 break;
c90c0ff4 1106 case OP_ENTEREVAL:
5196be3e 1107 scalarkids(o);
c90c0ff4 1108 break;
5aabfad6 1109 case OP_REQUIRE:
c90c0ff4 1110 /* all requires must return a boolean value */
5196be3e 1111 o->op_flags &= ~OPf_WANT;
d6483035
GS		 1112 /* FALL THROUGH */
1113 case OP_SCALAR:
5196be3e 1114 return scalar(o);
a0d0e21e 1115 case OP_SPLIT:
11343788 1116 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
20e98b0f 1117 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
12bcd1a6 1118 deprecate_old("implicit split to @_");
a0d0e21e
LW		 1119 }
1120 break;
79072805 1121 }
411caa50 1122 if (useless && ckWARN(WARN_VOID))
9014280d 1123 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 1124 return o;
79072805
LW		 1125}
1126
1127OP *
864dbfa3 1128Perl_listkids(pTHX_ OP *o)
79072805 1129{
11343788 1130 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1131 OP *kid;
11343788 1132 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1133 list(kid);
1134 }
11343788 1135 return o;
79072805
LW		 1136}
1137
1138OP *
864dbfa3 1139Perl_list(pTHX_ OP *o)
79072805 1140{
27da23d5 1141 dVAR;
79072805
LW		 1142 OP *kid;
1143
a0d0e21e 1144 /* assumes no premature commitment */
3280af22 1145 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 1146 || o->op_type == OP_RETURN)
7e363e51 1147 {
11343788 1148 return o;
7e363e51 1149 }
79072805 1150
b162f9ea 1151 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1152 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1153 {
b162f9ea 1154 return o; /* As if inside SASSIGN */
7e363e51 1155 }
1c846c1f 1156
5dc0d613 1157 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1158
11343788 1159 switch (o->op_type) {
79072805
LW		 1160 case OP_FLOP:
1161 case OP_REPEAT:
11343788 1162 list(cBINOPo->op_first);
79072805
LW		 1163 break;
1164 case OP_OR:
1165 case OP_AND:
1166 case OP_COND_EXPR:
11343788 1167 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1168 list(kid);
1169 break;
1170 default:
1171 case OP_MATCH:
8782bef2 1172 case OP_QR:
79072805
LW		 1173 case OP_SUBST:
1174 case OP_NULL:
11343788 1175 if (!(o->op_flags & OPf_KIDS))
79072805 1176 break;
11343788
MB		 1177 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1178 list(cBINOPo->op_first);
1179 return gen_constant_list(o);
79072805
LW		 1180 }
1181 case OP_LIST:
11343788 1182 listkids(o);
79072805
LW		 1183 break;
1184 case OP_LEAVE:
1185 case OP_LEAVETRY:
5dc0d613 1186 kid = cLISTOPo->op_first;
54310121 1187 list(kid);
155aba94 1188 while ((kid = kid->op_sibling)) {
54310121 1189 if (kid->op_sibling)
1190 scalarvoid(kid);
1191 else
1192 list(kid);
1193 }
11206fdd 1194 PL_curcop = &PL_compiling;
54310121 1195 break;
748a9306 1196 case OP_SCOPE:
79072805 1197 case OP_LINESEQ:
11343788 1198 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 1199 if (kid->op_sibling)
1200 scalarvoid(kid);
1201 else
1202 list(kid);
1203 }
11206fdd 1204 PL_curcop = &PL_compiling;
79072805 1205 break;
c90c0ff4 1206 case OP_REQUIRE:
1207 /* all requires must return a boolean value */
5196be3e
MB		 1208 o->op_flags &= ~OPf_WANT;
1209 return scalar(o);
79072805 1210 }
11343788 1211 return o;
79072805
LW		 1212}
1213
1214OP *
864dbfa3 1215Perl_scalarseq(pTHX_ OP *o)
79072805 1216{
97aff369 1217 dVAR;
11343788 1218 if (o) {
1496a290
AL		 1219 const OPCODE type = o->op_type;
1220
1221 if (type == OP_LINESEQ || type == OP_SCOPE ||
1222 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1223 {
6867be6d 1224 OP *kid;
11343788 1225 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1226 if (kid->op_sibling) {
463ee0b2 1227 scalarvoid(kid);
ed6116ce 1228 }
463ee0b2 1229 }
3280af22 1230 PL_curcop = &PL_compiling;
79072805 1231 }
11343788 1232 o->op_flags &= ~OPf_PARENS;
3280af22 1233 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1234 o->op_flags |= OPf_PARENS;
79072805 1235 }
8990e307 1236 else
11343788
MB		 1237 o = newOP(OP_STUB, 0);
1238 return o;
79072805
LW		 1239}
1240
76e3520e 1241STATIC OP *
cea2e8a9 1242S_modkids(pTHX_ OP *o, I32 type)
79072805 1243{
11343788 1244 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1245 OP *kid;
11343788 1246 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1247 mod(kid, type);
79072805 1248 }
11343788 1249 return o;
79072805
LW		 1250}
1251
ff7298cb 1252/* Propagate lvalue ("modifiable") context to an op and its children.
ddeae0f1
DM		 1253 * 'type' represents the context type, roughly based on the type of op that
1254 * would do the modifying, although local() is represented by OP_NULL.
1255 * It's responsible for detecting things that can't be modified, flag
1256 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1257 * might have to vivify a reference in $x), and so on.
1258 *
1259 * For example, "$a+1 = 2" would cause mod() to be called with o being
1260 * OP_ADD and type being OP_SASSIGN, and would output an error.
1261 */
1262
79072805 1263OP *
864dbfa3 1264Perl_mod(pTHX_ OP *o, I32 type)
79072805 1265{
27da23d5 1266 dVAR;
79072805 1267 OP *kid;
ddeae0f1
DM		 1268 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1269 int localize = -1;
79072805 1270
3280af22 1271 if (!o || PL_error_count)
11343788 1272 return o;
79072805 1273
b162f9ea 1274 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1275 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1276 {
b162f9ea 1277 return o;
7e363e51 1278 }
1c846c1f 1279
11343788 1280 switch (o->op_type) {
68dc0745 1281 case OP_UNDEF:
ddeae0f1 1282 localize = 0;
3280af22 1283 PL_modcount++;
5dc0d613 1284 return o;
a0d0e21e 1285 case OP_CONST:
2e0ae2d3 1286 if (!(o->op_private & OPpCONST_ARYBASE))
a0d0e21e 1287 goto nomod;
54dc0f91 1288 localize = 0;
3280af22 1289 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
fc15ae8f
NC		 1290 CopARYBASE_set(&PL_compiling,
1291 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
3280af22 1292 PL_eval_start = 0;
a0d0e21e
LW		 1293 }
1294 else if (!type) {
fc15ae8f
NC		 1295 SAVECOPARYBASE(&PL_compiling);
1296 CopARYBASE_set(&PL_compiling, 0);
a0d0e21e
LW		 1297 }
1298 else if (type == OP_REFGEN)
1299 goto nomod;
1300 else
cea2e8a9 1301 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1302 break;
5f05dabc 1303 case OP_STUB:
58bde88d 1304 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc 1305 break;
1306 goto nomod;
a0d0e21e
LW		 1307 case OP_ENTERSUB:
1308 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1309 !(o->op_flags & OPf_STACKED)) {
1310 o->op_type = OP_RV2CV; /* entersub => rv2cv */
e26df76a
NC		 1311 /* The default is to set op_private to the number of children,
1312 which for a UNOP such as RV2CV is always 1. And w're using
1313 the bit for a flag in RV2CV, so we need it clear. */
1314 o->op_private &= ~1;
22c35a8c 1315 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1316 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1317 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1318 break;
1319 }
95f0a2f1
SB		 1320 else if (o->op_private & OPpENTERSUB_NOMOD)
1321 return o;
cd06dffe
GS		 1322 else { /* lvalue subroutine call */
1323 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1324 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1325 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1326 /* Backward compatibility mode: */
1327 o->op_private |= OPpENTERSUB_INARGS;
1328 break;
1329 }
1330 else { /* Compile-time error message: */
1331 OP *kid = cUNOPo->op_first;
1332 CV *cv;
1333 OP *okid;
1334
3ea285d1
AL		 1335 if (kid->op_type != OP_PUSHMARK) {
1336 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1337 Perl_croak(aTHX_
1338 "panic: unexpected lvalue entersub "
1339 "args: type/targ %ld:%"UVuf,
1340 (long)kid->op_type, (UV)kid->op_targ);
1341 kid = kLISTOP->op_first;
1342 }
cd06dffe
GS		 1343 while (kid->op_sibling)
1344 kid = kid->op_sibling;
1345 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1346 /* Indirect call */
1347 if (kid->op_type == OP_METHOD_NAMED
1348 || kid->op_type == OP_METHOD)
1349 {
87d7fd28 1350 UNOP *newop;
b2ffa427 1351
87d7fd28 1352 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1353 newop->op_type = OP_RV2CV;
1354 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
5f66b61c 1355 newop->op_first = NULL;
87d7fd28
GS		 1356 newop->op_next = (OP*)newop;
1357 kid->op_sibling = (OP*)newop;
349fd7b7 1358 newop->op_private |= OPpLVAL_INTRO;
e26df76a 1359 newop->op_private &= ~1;
cd06dffe
GS		 1360 break;
1361 }
b2ffa427 1362
cd06dffe
GS		 1363 if (kid->op_type != OP_RV2CV)
1364 Perl_croak(aTHX_
1365 "panic: unexpected lvalue entersub "
55140b79 1366 "entry via type/targ %ld:%"UVuf,
3d811634 1367 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1368 kid->op_private |= OPpLVAL_INTRO;
1369 break; /* Postpone until runtime */
1370 }
b2ffa427
NIS		 1371
1372 okid = kid;
cd06dffe
GS		 1373 kid = kUNOP->op_first;
1374 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1375 kid = kUNOP->op_first;
b2ffa427 1376 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1377 Perl_croak(aTHX_
1378 "Unexpected constant lvalue entersub "
55140b79 1379 "entry via type/targ %ld:%"UVuf,
3d811634 1380 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1381 if (kid->op_type != OP_GV) {
1382 /* Restore RV2CV to check lvalueness */
1383 restore_2cv:
1384 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1385 okid->op_next = kid->op_next;
1386 kid->op_next = okid;
1387 }
1388 else
5f66b61c 1389 okid->op_next = NULL;
cd06dffe
GS		 1390 okid->op_type = OP_RV2CV;
1391 okid->op_targ = 0;
1392 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1393 okid->op_private |= OPpLVAL_INTRO;
e26df76a 1394 okid->op_private &= ~1;
cd06dffe
GS		 1395 break;
1396 }
b2ffa427 1397
638eceb6 1398 cv = GvCV(kGVOP_gv);
1c846c1f 1399 if (!cv)
cd06dffe
GS		 1400 goto restore_2cv;
1401 if (CvLVALUE(cv))
1402 break;
1403 }
1404 }
79072805
LW		 1405 /* FALL THROUGH */
1406 default:
a0d0e21e 1407 nomod:
6fbb66d6
NC		 1408 /* grep, foreach, subcalls, refgen */
1409 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
a0d0e21e 1410 break;
cea2e8a9 1411 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1412 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1413 ? "do block"
1414 : (o->op_type == OP_ENTERSUB
1415 ? "non-lvalue subroutine call"
53e06cf0 1416 : OP_DESC(o))),
22c35a8c 1417 type ? PL_op_desc[type] : "local"));
11343788 1418 return o;
79072805 1419
a0d0e21e
LW		 1420 case OP_PREINC:
1421 case OP_PREDEC:
1422 case OP_POW:
1423 case OP_MULTIPLY:
1424 case OP_DIVIDE:
1425 case OP_MODULO:
1426 case OP_REPEAT:
1427 case OP_ADD:
1428 case OP_SUBTRACT:
1429 case OP_CONCAT:
1430 case OP_LEFT_SHIFT:
1431 case OP_RIGHT_SHIFT:
1432 case OP_BIT_AND:
1433 case OP_BIT_XOR:
1434 case OP_BIT_OR:
1435 case OP_I_MULTIPLY:
1436 case OP_I_DIVIDE:
1437 case OP_I_MODULO:
1438 case OP_I_ADD:
1439 case OP_I_SUBTRACT:
11343788 1440 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1441 goto nomod;
3280af22 1442 PL_modcount++;
a0d0e21e 1443 break;
b2ffa427 1444
79072805 1445 case OP_COND_EXPR:
ddeae0f1 1446 localize = 1;
11343788 1447 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1448 mod(kid, type);
79072805
LW		 1449 break;
1450
1451 case OP_RV2AV:
1452 case OP_RV2HV:
11343788 1453 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1454 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1455 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1456 }
1457 /* FALL THROUGH */
79072805 1458 case OP_RV2GV:
5dc0d613 1459 if (scalar_mod_type(o, type))
3fe9a6f1 1460 goto nomod;
11343788 1461 ref(cUNOPo->op_first, o->op_type);
79072805 1462 /* FALL THROUGH */
79072805
LW		 1463 case OP_ASLICE:
1464 case OP_HSLICE:
78f9721b
SM		 1465 if (type == OP_LEAVESUBLV)
1466 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1467 localize = 1;
78f9721b
SM		 1468 /* FALL THROUGH */
1469 case OP_AASSIGN:
93a17b20
LW		 1470 case OP_NEXTSTATE:
1471 case OP_DBSTATE:
e6438c1a 1472 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1473 break;
463ee0b2 1474 case OP_RV2SV:
aeea060c 1475 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1476 localize = 1;
463ee0b2 1477 /* FALL THROUGH */
79072805 1478 case OP_GV:
463ee0b2 1479 case OP_AV2ARYLEN:
3280af22 1480 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1481 case OP_SASSIGN:
bf4b1e52
GS		 1482 case OP_ANDASSIGN:
1483 case OP_ORASSIGN:
c963b151 1484 case OP_DORASSIGN:
ddeae0f1
DM		 1485 PL_modcount++;
1486 break;
1487
8990e307 1488 case OP_AELEMFAST:
6a077020 1489 localize = -1;
3280af22 1490 PL_modcount++;
8990e307
LW		 1491 break;
1492
748a9306
LW		 1493 case OP_PADAV:
1494 case OP_PADHV:
e6438c1a 1495 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1496 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1497 return o; /* Treat \(@foo) like ordinary list. */
1498 if (scalar_mod_type(o, type))
3fe9a6f1 1499 goto nomod;
78f9721b
SM		 1500 if (type == OP_LEAVESUBLV)
1501 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1502 /* FALL THROUGH */
1503 case OP_PADSV:
3280af22 1504 PL_modcount++;
ddeae0f1 1505 if (!type) /* local() */
cea2e8a9 1506 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1507 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW		 1508 break;
1509
748a9306 1510 case OP_PUSHMARK:
ddeae0f1 1511 localize = 0;
748a9306 1512 break;
b2ffa427 1513
69969c6f
SB		 1514 case OP_KEYS:
1515 if (type != OP_SASSIGN)
1516 goto nomod;
5d82c453
GA		 1517 goto lvalue_func;
1518 case OP_SUBSTR:
1519 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1520 goto nomod;
5f05dabc 1521 /* FALL THROUGH */
a0d0e21e 1522 case OP_POS:
463ee0b2 1523 case OP_VEC:
78f9721b
SM		 1524 if (type == OP_LEAVESUBLV)
1525 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1526 lvalue_func:
11343788
MB		 1527 pad_free(o->op_targ);
1528 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1529 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1530 if (o->op_flags & OPf_KIDS)
1531 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1532 break;
a0d0e21e 1533
463ee0b2
LW		 1534 case OP_AELEM:
1535 case OP_HELEM:
11343788 1536 ref(cBINOPo->op_first, o->op_type);
68dc0745 1537 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1538 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1539 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1540 if (type == OP_LEAVESUBLV)
1541 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1542 localize = 1;
3280af22 1543 PL_modcount++;
463ee0b2
LW		 1544 break;
1545
1546 case OP_SCOPE:
1547 case OP_LEAVE:
1548 case OP_ENTER:
78f9721b 1549 case OP_LINESEQ:
ddeae0f1 1550 localize = 0;
11343788
MB		 1551 if (o->op_flags & OPf_KIDS)
1552 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1553 break;
1554
1555 case OP_NULL:
ddeae0f1 1556 localize = 0;
638bc118
GS		 1557 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1558 goto nomod;
1559 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1560 break;
11343788
MB		 1561 if (o->op_targ != OP_LIST) {
1562 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1563 break;
1564 }
1565 /* FALL THROUGH */
463ee0b2 1566 case OP_LIST:
ddeae0f1 1567 localize = 0;
11343788 1568 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1569 mod(kid, type);
1570 break;
78f9721b
SM		 1571
1572 case OP_RETURN:
1573 if (type != OP_LEAVESUBLV)
1574 goto nomod;
1575 break; /* mod()ing was handled by ck_return() */
463ee0b2 1576 }
58d95175 1577
8be1be90
AMS		 1578 /* [20011101.069] File test operators interpret OPf_REF to mean that
1579 their argument is a filehandle; thus \stat(".") should not set
1580 it. AMS 20011102 */
1581 if (type == OP_REFGEN &&
1582 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1583 return o;
1584
1585 if (type != OP_LEAVESUBLV)
1586 o->op_flags |= OPf_MOD;
1587
1588 if (type == OP_AASSIGN || type == OP_SASSIGN)
1589 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 1590 else if (!type) { /* local() */
1591 switch (localize) {
1592 case 1:
1593 o->op_private |= OPpLVAL_INTRO;
1594 o->op_flags &= ~OPf_SPECIAL;
1595 PL_hints |= HINT_BLOCK_SCOPE;
1596 break;
1597 case 0:
1598 break;
1599 case -1:
1600 if (ckWARN(WARN_SYNTAX)) {
1601 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1602 "Useless localization of %s", OP_DESC(o));
1603 }
1604 }
463ee0b2 1605 }
8be1be90
AMS		 1606 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1607 && type != OP_LEAVESUBLV)
1608 o->op_flags |= OPf_REF;
11343788 1609 return o;
463ee0b2
LW		 1610}
1611
864dbfa3 1612STATIC bool
5f66b61c 1613S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 1614{
1615 switch (type) {
1616 case OP_SASSIGN:
5196be3e 1617 if (o->op_type == OP_RV2GV)
3fe9a6f1 1618 return FALSE;
1619 /* FALL THROUGH */
1620 case OP_PREINC:
1621 case OP_PREDEC:
1622 case OP_POSTINC:
1623 case OP_POSTDEC:
1624 case OP_I_PREINC:
1625 case OP_I_PREDEC:
1626 case OP_I_POSTINC:
1627 case OP_I_POSTDEC:
1628 case OP_POW:
1629 case OP_MULTIPLY:
1630 case OP_DIVIDE:
1631 case OP_MODULO:
1632 case OP_REPEAT:
1633 case OP_ADD:
1634 case OP_SUBTRACT:
1635 case OP_I_MULTIPLY:
1636 case OP_I_DIVIDE:
1637 case OP_I_MODULO:
1638 case OP_I_ADD:
1639 case OP_I_SUBTRACT:
1640 case OP_LEFT_SHIFT:
1641 case OP_RIGHT_SHIFT:
1642 case OP_BIT_AND:
1643 case OP_BIT_XOR:
1644 case OP_BIT_OR:
1645 case OP_CONCAT:
1646 case OP_SUBST:
1647 case OP_TRANS:
49e9fbe6
GS		 1648 case OP_READ:
1649 case OP_SYSREAD:
1650 case OP_RECV:
bf4b1e52
GS		 1651 case OP_ANDASSIGN:
1652 case OP_ORASSIGN:
410d09fe 1653 case OP_DORASSIGN:
3fe9a6f1 1654 return TRUE;
1655 default:
1656 return FALSE;
1657 }
1658}
1659
35cd451c 1660STATIC bool
5f66b61c 1661S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c
GS		 1662{
1663 switch (o->op_type) {
1664 case OP_PIPE_OP:
1665 case OP_SOCKPAIR:
504618e9 1666 if (numargs == 2)
35cd451c
GS		 1667 return TRUE;
1668 /* FALL THROUGH */
1669 case OP_SYSOPEN:
1670 case OP_OPEN:
ded8aa31 1671 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1672 case OP_SOCKET:
1673 case OP_OPEN_DIR:
1674 case OP_ACCEPT:
504618e9 1675 if (numargs == 1)
35cd451c 1676 return TRUE;
5f66b61c 1677 /* FALLTHROUGH */
35cd451c
GS		 1678 default:
1679 return FALSE;
1680 }
1681}
1682
463ee0b2 1683OP *
864dbfa3 1684Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2 1685{
11343788 1686 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1687 OP *kid;
11343788 1688 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1689 ref(kid, type);
1690 }
11343788 1691 return o;
463ee0b2
LW		 1692}
1693
1694OP *
e4c5ccf3 1695Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 1696{
27da23d5 1697 dVAR;
463ee0b2 1698 OP *kid;
463ee0b2 1699
3280af22 1700 if (!o || PL_error_count)
11343788 1701 return o;
463ee0b2 1702
11343788 1703 switch (o->op_type) {
a0d0e21e 1704 case OP_ENTERSUB:
afebc493 1705 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1706 !(o->op_flags & OPf_STACKED)) {
1707 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1708 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1709 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1710 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1711 o->op_flags |= OPf_SPECIAL;
e26df76a 1712 o->op_private &= ~1;
8990e307
LW		 1713 }
1714 break;
aeea060c 1715
463ee0b2 1716 case OP_COND_EXPR:
11343788 1717 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 1718 doref(kid, type, set_op_ref);
463ee0b2 1719 break;
8990e307 1720 case OP_RV2SV:
35cd451c
GS		 1721 if (type == OP_DEFINED)
1722 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1723 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 1724 /* FALL THROUGH */
1725 case OP_PADSV:
5f05dabc 1726 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1727 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1728 : type == OP_RV2HV ? OPpDEREF_HV
1729 : OPpDEREF_SV);
11343788 1730 o->op_flags |= OPf_MOD;
a0d0e21e 1731 }
8990e307 1732 break;
1c846c1f 1733
463ee0b2
LW		 1734 case OP_RV2AV:
1735 case OP_RV2HV:
e4c5ccf3
RH		 1736 if (set_op_ref)
1737 o->op_flags |= OPf_REF;
8990e307 1738 /* FALL THROUGH */
463ee0b2 1739 case OP_RV2GV:
35cd451c
GS		 1740 if (type == OP_DEFINED)
1741 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1742 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 1743 break;
8990e307 1744
463ee0b2
LW		 1745 case OP_PADAV:
1746 case OP_PADHV:
e4c5ccf3
RH		 1747 if (set_op_ref)
1748 o->op_flags |= OPf_REF;
79072805 1749 break;
aeea060c 1750
8990e307 1751 case OP_SCALAR:
79072805 1752 case OP_NULL:
11343788 1753 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1754 break;
e4c5ccf3 1755 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 1756 break;
1757 case OP_AELEM:
1758 case OP_HELEM:
e4c5ccf3 1759 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 1760 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1761 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1762 : type == OP_RV2HV ? OPpDEREF_HV
1763 : OPpDEREF_SV);
11343788 1764 o->op_flags |= OPf_MOD;
8990e307 1765 }
79072805
LW		 1766 break;
1767
463ee0b2 1768 case OP_SCOPE:
79072805 1769 case OP_LEAVE:
e4c5ccf3
RH		 1770 set_op_ref = FALSE;
1771 /* FALL THROUGH */
79072805 1772 case OP_ENTER:
8990e307 1773 case OP_LIST:
11343788 1774 if (!(o->op_flags & OPf_KIDS))
79072805 1775 break;
e4c5ccf3 1776 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 1777 break;
a0d0e21e
LW		 1778 default:
1779 break;
79072805 1780 }
11343788 1781 return scalar(o);
8990e307 1782
79072805
LW		 1783}
1784
09bef843
SB		 1785STATIC OP *
1786S_dup_attrlist(pTHX_ OP *o)
1787{
97aff369 1788 dVAR;
0bd48802 1789 OP *rop;
09bef843
SB		 1790
1791 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1792 * where the first kid is OP_PUSHMARK and the remaining ones
1793 * are OP_CONST. We need to push the OP_CONST values.
1794 */
1795 if (o->op_type == OP_CONST)
b37c2d43 1796 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 1797#ifdef PERL_MAD
1798 else if (o->op_type == OP_NULL)
1d866c12 1799 rop = NULL;
eb8433b7 1800#endif
09bef843
SB		 1801 else {
1802 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 1803 rop = NULL;
09bef843
SB		 1804 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1805 if (o->op_type == OP_CONST)
1806 rop = append_elem(OP_LIST, rop,
1807 newSVOP(OP_CONST, o->op_flags,
b37c2d43 1808 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 1809 }
1810 }
1811 return rop;
1812}
1813
1814STATIC void
95f0a2f1 1815S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1816{
27da23d5 1817 dVAR;
09bef843
SB		 1818 SV *stashsv;
1819
1820 /* fake up C<use attributes $pkg,$rv,@attrs> */
1821 ENTER; /* need to protect against side-effects of 'use' */
5aaec2b4 1822 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 1823
09bef843 1824#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1825#define ATTRSMODULE_PM "attributes.pm"
1826
1827 if (for_my) {
95f0a2f1 1828 /* Don't force the C<use> if we don't need it. */
a4fc7abc 1829 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 1830 if (svp && *svp != &PL_sv_undef)
6f207bd3 1831 NOOP; /* already in %INC */
95f0a2f1
SB		 1832 else
1833 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 1834 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 1835 }
1836 else {
1837 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 1838 newSVpvs(ATTRSMODULE),
1839 NULL,
95f0a2f1
SB		 1840 prepend_elem(OP_LIST,
1841 newSVOP(OP_CONST, 0, stashsv),
1842 prepend_elem(OP_LIST,
1843 newSVOP(OP_CONST, 0,
1844 newRV(target)),
1845 dup_attrlist(attrs))));
1846 }
09bef843
SB		 1847 LEAVE;
1848}
1849
95f0a2f1
SB		 1850STATIC void
1851S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1852{
97aff369 1853 dVAR;
95f0a2f1
SB		 1854 OP *pack, *imop, *arg;
1855 SV *meth, *stashsv;
1856
1857 if (!attrs)
1858 return;
1859
1860 assert(target->op_type == OP_PADSV ||
1861 target->op_type == OP_PADHV ||
1862 target->op_type == OP_PADAV);
1863
1864 /* Ensure that attributes.pm is loaded. */
dd2155a4 1865 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 1866
1867 /* Need package name for method call. */
6136c704 1868 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 1869
1870 /* Build up the real arg-list. */
5aaec2b4
NC		 1871 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1872
95f0a2f1
SB		 1873 arg = newOP(OP_PADSV, 0);
1874 arg->op_targ = target->op_targ;
1875 arg = prepend_elem(OP_LIST,
1876 newSVOP(OP_CONST, 0, stashsv),
1877 prepend_elem(OP_LIST,
1878 newUNOP(OP_REFGEN, 0,
1879 mod(arg, OP_REFGEN)),
1880 dup_attrlist(attrs)));
1881
1882 /* Fake up a method call to import */
18916d0d 1883 meth = newSVpvs_share("import");
95f0a2f1
SB		 1884 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1885 append_elem(OP_LIST,
1886 prepend_elem(OP_LIST, pack, list(arg)),
1887 newSVOP(OP_METHOD_NAMED, 0, meth)));
1888 imop->op_private |= OPpENTERSUB_NOMOD;
1889
1890 /* Combine the ops. */
1891 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1892}
1893
1894/*
1895=notfor apidoc apply_attrs_string
1896
1897Attempts to apply a list of attributes specified by the C<attrstr> and
1898C<len> arguments to the subroutine identified by the C<cv> argument which
1899is expected to be associated with the package identified by the C<stashpv>
1900argument (see L<attributes>). It gets this wrong, though, in that it
1901does not correctly identify the boundaries of the individual attribute
1902specifications within C<attrstr>. This is not really intended for the
1903public API, but has to be listed here for systems such as AIX which
1904need an explicit export list for symbols. (It's called from XS code
1905in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1906to respect attribute syntax properly would be welcome.
1907
1908=cut
1909*/
1910
be3174d2 1911void
6867be6d
AL		 1912Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1913 const char *attrstr, STRLEN len)
be3174d2 1914{
5f66b61c 1915 OP *attrs = NULL;
be3174d2
GS		 1916
1917 if (!len) {
1918 len = strlen(attrstr);
1919 }
1920
1921 while (len) {
1922 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1923 if (len) {
890ce7af 1924 const char * const sstr = attrstr;
be3174d2
GS		 1925 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1926 attrs = append_elem(OP_LIST, attrs,
1927 newSVOP(OP_CONST, 0,
1928 newSVpvn(sstr, attrstr-sstr)));
1929 }
1930 }
1931
1932 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 1933 newSVpvs(ATTRSMODULE),
a0714e2c 1934 NULL, prepend_elem(OP_LIST,
be3174d2
GS		 1935 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1936 prepend_elem(OP_LIST,
1937 newSVOP(OP_CONST, 0,
1938 newRV((SV*)cv)),
1939 attrs)));
1940}
1941
09bef843 1942STATIC OP *
95f0a2f1 1943S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 1944{
97aff369 1945 dVAR;
93a17b20
LW		 1946 I32 type;
1947
3280af22 1948 if (!o || PL_error_count)
11343788 1949 return o;
93a17b20 1950
bc61e325 1951 type = o->op_type;
eb8433b7
NC		 1952 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1953 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1954 return o;
1955 }
1956
93a17b20 1957 if (type == OP_LIST) {
6867be6d 1958 OP *kid;
11343788 1959 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1960 my_kid(kid, attrs, imopsp);
eb8433b7
NC		 1961 } else if (type == OP_UNDEF
1962#ifdef PERL_MAD
1963 || type == OP_STUB
1964#endif
1965 ) {
7766148a 1966 return o;
77ca0c92
LW		 1967 } else if (type == OP_RV2SV || /* "our" declaration */
1968 type == OP_RV2AV ||
1969 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 1970 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 1971 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 1972 OP_DESC(o),
12bd6ede
DM		 1973 PL_parser->in_my == KEY_our
1974 ? "our"
1975 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 1976 } else if (attrs) {
551405c4 1977 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM		 1978 PL_parser->in_my = FALSE;
1979 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS		 1980 apply_attrs(GvSTASH(gv),
1981 (type == OP_RV2SV ? GvSV(gv) :
1982 type == OP_RV2AV ? (SV*)GvAV(gv) :
1983 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1984 attrs, FALSE);
1985 }
192587c2 1986 o->op_private |= OPpOUR_INTRO;
77ca0c92 1987 return o;
95f0a2f1
SB		 1988 }
1989 else if (type != OP_PADSV &&
93a17b20
LW		 1990 type != OP_PADAV &&
1991 type != OP_PADHV &&
1992 type != OP_PUSHMARK)
1993 {
eb64745e 1994 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1995 OP_DESC(o),
12bd6ede
DM		 1996 PL_parser->in_my == KEY_our
1997 ? "our"
1998 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 1999 return o;
93a17b20 2000 }
09bef843
SB		 2001 else if (attrs && type != OP_PUSHMARK) {
2002 HV *stash;
09bef843 2003
12bd6ede
DM		 2004 PL_parser->in_my = FALSE;
2005 PL_parser->in_my_stash = NULL;
eb64745e 2006
09bef843 2007 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 2008 stash = PAD_COMPNAME_TYPE(o->op_targ);
2009 if (!stash)
09bef843 2010 stash = PL_curstash;
95f0a2f1 2011 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2012 }
11343788
MB		 2013 o->op_flags |= OPf_MOD;
2014 o->op_private |= OPpLVAL_INTRO;
12bd6ede 2015 if (PL_parser->in_my == KEY_state)
952306ac 2016 o->op_private |= OPpPAD_STATE;
11343788 2017 return o;
93a17b20
LW		 2018}
2019
2020OP *
09bef843
SB		 2021Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2022{
97aff369 2023 dVAR;
0bd48802 2024 OP *rops;
95f0a2f1
SB		 2025 int maybe_scalar = 0;
2026
d2be0de5 2027/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2028 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2029#if 0
09bef843
SB		 2030 if (o->op_flags & OPf_PARENS)
2031 list(o);
95f0a2f1
SB		 2032 else
2033 maybe_scalar = 1;
d2be0de5
YST		 2034#else
2035 maybe_scalar = 1;
2036#endif
09bef843
SB		 2037 if (attrs)
2038 SAVEFREEOP(attrs);
5f66b61c 2039 rops = NULL;
95f0a2f1
SB		 2040 o = my_kid(o, attrs, &rops);
2041 if (rops) {
2042 if (maybe_scalar && o->op_type == OP_PADSV) {
2043 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2044 o->op_private |= OPpLVAL_INTRO;
2045 }
2046 else
2047 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2048 }
12bd6ede
DM		 2049 PL_parser->in_my = FALSE;
2050 PL_parser->in_my_stash = NULL;
eb64745e 2051 return o;
09bef843
SB		 2052}
2053
2054OP *
2055Perl_my(pTHX_ OP *o)
2056{
5f66b61c 2057 return my_attrs(o, NULL);
09bef843
SB		 2058}
2059
2060OP *
864dbfa3 2061Perl_sawparens(pTHX_ OP *o)
79072805 2062{
96a5add6 2063 PERL_UNUSED_CONTEXT;
79072805
LW		 2064 if (o)
2065 o->op_flags |= OPf_PARENS;
2066 return o;
2067}
2068
2069OP *
864dbfa3 2070Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2071{
11343788 2072 OP *o;
59f00321 2073 bool ismatchop = 0;
1496a290
AL		 2074 const OPCODE ltype = left->op_type;
2075 const OPCODE rtype = right->op_type;
79072805 2076
1496a290
AL		 2077 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2078 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2079 {
1496a290 2080 const char * const desc
666ea192
JH		 2081 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2082 ? (int)rtype : OP_MATCH];
2083 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2084 ? "@array" : "%hash");
9014280d 2085 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2086 "Applying %s to %s will act on scalar(%s)",
599cee73 2087 desc, sample, sample);
2ae324a7 2088 }
2089
1496a290 2090 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2091 cSVOPx(right)->op_private & OPpCONST_BARE &&
2092 cSVOPx(right)->op_private & OPpCONST_STRICT)
2093 {
2094 no_bareword_allowed(right);
2095 }
2096
1496a290
AL		 2097 ismatchop = rtype == OP_MATCH ||
2098 rtype == OP_SUBST ||
2099 rtype == OP_TRANS;
59f00321
RGS		 2100 if (ismatchop && right->op_private & OPpTARGET_MY) {
2101 right->op_targ = 0;
2102 right->op_private &= ~OPpTARGET_MY;
2103 }
2104 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2105 OP *newleft;
2106
79072805 2107 right->op_flags |= OPf_STACKED;
1496a290
AL		 2108 if (rtype != OP_MATCH &&
2109 ! (rtype == OP_TRANS &&
6fbb66d6 2110 right->op_private & OPpTRANS_IDENTICAL))
1496a290
AL		 2111 newleft = mod(left, rtype);
2112 else
2113 newleft = left;
79072805 2114 if (right->op_type == OP_TRANS)
1496a290 2115 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2116 else
1496a290 2117 o = prepend_elem(rtype, scalar(newleft), right);
79072805 2118 if (type == OP_NOT)
11343788
MB		 2119 return newUNOP(OP_NOT, 0, scalar(o));
2120 return o;
79072805
LW		 2121 }
2122 else
2123 return bind_match(type, left,
131b3ad0 2124 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 2125}
2126
2127OP *
864dbfa3 2128Perl_invert(pTHX_ OP *o)
79072805 2129{
11343788 2130 if (!o)
1d866c12 2131 return NULL;
11343788 2132 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2133}
2134
2135OP *
864dbfa3 2136Perl_scope(pTHX_ OP *o)
79072805 2137{
27da23d5 2138 dVAR;
79072805 2139 if (o) {
3280af22 2140 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 2141 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2142 o->op_type = OP_LEAVE;
22c35a8c 2143 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2144 }
fdb22418
HS		 2145 else if (o->op_type == OP_LINESEQ) {
2146 OP *kid;
2147 o->op_type = OP_SCOPE;
2148 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2149 kid = ((LISTOP*)o)->op_first;
59110972 2150 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2151 op_null(kid);
59110972
RH		 2152
2153 /* The following deals with things like 'do {1 for 1}' */
2154 kid = kid->op_sibling;
2155 if (kid &&
2156 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2157 op_null(kid);
2158 }
463ee0b2 2159 }
fdb22418 2160 else
5f66b61c 2161 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2162 }
2163 return o;
2164}
72dc9ed5 2165
a0d0e21e 2166int
864dbfa3 2167Perl_block_start(pTHX_ int full)
79072805 2168{
97aff369 2169 dVAR;
73d840c0 2170 const int retval = PL_savestack_ix;
dd2155a4 2171 pad_block_start(full);
b3ac6de7 2172 SAVEHINTS();
3280af22 2173 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2174 SAVECOMPILEWARNINGS();
72dc9ed5 2175 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
a0d0e21e
LW		 2176 return retval;
2177}
2178
2179OP*
864dbfa3 2180Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2181{
97aff369 2182 dVAR;
6867be6d 2183 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
551405c4 2184 OP* const retval = scalarseq(seq);
e9818f4e 2185 LEAVE_SCOPE(floor);
623e6609 2186 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2187 if (needblockscope)
3280af22 2188 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 2189 pad_leavemy();
a0d0e21e
LW		 2190 return retval;
2191}
2192
76e3520e 2193STATIC OP *
cea2e8a9 2194S_newDEFSVOP(pTHX)
54b9620d 2195{
97aff369 2196 dVAR;
9f7d9405 2197 const PADOFFSET offset = pad_findmy("$_");
00b1698f 2198 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2199 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2200 }
2201 else {
551405c4 2202 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2203 o->op_targ = offset;
2204 return o;
2205 }
54b9620d
MB		 2206}
2207
a0d0e21e 2208void
864dbfa3 2209Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2210{
97aff369 2211 dVAR;
3280af22 2212 if (PL_in_eval) {
b295d113
TH		 2213 if (PL_eval_root)
2214 return;
faef0170
HS		 2215 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2216 ((PL_in_eval & EVAL_KEEPERR)
2217 ? OPf_SPECIAL : 0), o);
3280af22 2218 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 2219 PL_eval_root->op_private |= OPpREFCOUNTED;
2220 OpREFCNT_set(PL_eval_root, 1);
3280af22 2221 PL_eval_root->op_next = 0;
a2efc822 2222 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 2223 }
2224 else {
6be89cf9
AE		 2225 if (o->op_type == OP_STUB) {
2226 PL_comppad_name = 0;
2227 PL_compcv = 0;
d2c837a0 2228 S_op_destroy(aTHX_ o);
a0d0e21e 2229 return;
6be89cf9 2230 }
3280af22
NIS		 2231 PL_main_root = scope(sawparens(scalarvoid(o)));
2232 PL_curcop = &PL_compiling;
2233 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2234 PL_main_root->op_private |= OPpREFCOUNTED;
2235 OpREFCNT_set(PL_main_root, 1);
3280af22 2236 PL_main_root->op_next = 0;
a2efc822 2237 CALL_PEEP(PL_main_start);
3280af22 2238 PL_compcv = 0;
3841441e 2239
4fdae800 2240 /* Register with debugger */
84902520 2241 if (PERLDB_INTER) {
780a5241
NC		 2242 CV * const cv
2243 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
3841441e
CS		 2244 if (cv) {
2245 dSP;
924508f0 2246 PUSHMARK(SP);
cc49e20b 2247 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2248 PUTBACK;
864dbfa3 2249 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 2250 }
2251 }
79072805 2252 }
79072805
LW		 2253}
2254
2255OP *
864dbfa3 2256Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2257{
97aff369 2258 dVAR;
79072805 2259 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2260/* [perl #17376]: this appears to be premature, and results in code such as
2261 C< our(%x); > executing in list mode rather than void mode */
2262#if 0
79072805 2263 list(o);
d2be0de5 2264#else
6f207bd3 2265 NOOP;
d2be0de5 2266#endif
8990e307 2267 else {
f06b5848
DM		 2268 if ( PL_parser->bufptr > PL_parser->oldbufptr
2269 && PL_parser->bufptr[-1] == ','
041457d9 2270 && ckWARN(WARN_PARENTHESIS))
64420d0d 2271 {
f06b5848 2272 char *s = PL_parser->bufptr;
bac662ee 2273 bool sigil = FALSE;
64420d0d 2274
8473848f 2275 /* some heuristics to detect a potential error */
bac662ee 2276 while (*s && (strchr(", \t\n", *s)))
64420d0d 2277 s++;
8473848f 2278
bac662ee
TS		 2279 while (1) {
2280 if (*s && strchr("@$%*", *s) && *++s
2281 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2282 s++;
2283 sigil = TRUE;
2284 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2285 s++;
2286 while (*s && (strchr(", \t\n", *s)))
2287 s++;
2288 }
2289 else
2290 break;
2291 }
2292 if (sigil && (*s == ';' || *s == '=')) {
2293 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 2294 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 2295 lex
2296 ? (PL_parser->in_my == KEY_our
2297 ? "our"
2298 : PL_parser->in_my == KEY_state
2299 ? "state"
2300 : "my")
2301 : "local");
8473848f 2302 }
8990e307
LW		 2303 }
2304 }
93a17b20 2305 if (lex)
eb64745e 2306 o = my(o);
93a17b20 2307 else
eb64745e 2308 o = mod(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 2309 PL_parser->in_my = FALSE;
2310 PL_parser->in_my_stash = NULL;
eb64745e 2311 return o;
79072805
LW		 2312}
2313
2314OP *
864dbfa3 2315Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2316{
2317 if (o->op_type == OP_LIST) {
fafc274c 2318 OP * const o2
d4c19fe8 2319 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
554b3eca 2320 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2321 }
2322 return o;
2323}
2324
2325OP *
864dbfa3 2326Perl_fold_constants(pTHX_ register OP *o)
79072805 2327{
27da23d5 2328 dVAR;
79072805 2329 register OP *curop;
eb8433b7 2330 OP *newop;
8ea43dc8 2331 VOL I32 type = o->op_type;
e3cbe32f 2332 SV * VOL sv = NULL;
b7f7fd0b
NC		 2333 int ret = 0;
2334 I32 oldscope;
2335 OP *old_next;
5f2d9966
DM		 2336 SV * const oldwarnhook = PL_warnhook;
2337 SV * const olddiehook = PL_diehook;
b7f7fd0b 2338 dJMPENV;
79072805 2339
22c35a8c 2340 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2341 scalar(o);
b162f9ea 2342 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2343 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2344
eac055e9
GS		 2345 /* integerize op, unless it happens to be C<-foo>.
2346 * XXX should pp_i_negate() do magic string negation instead? */
2347 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2348 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2349 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2350 {
22c35a8c 2351 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2352 }
85e6fe83 2353
22c35a8c 2354 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2355 goto nope;
2356
de939608 2357 switch (type) {
7a52d87a
GS		 2358 case OP_NEGATE:
2359 /* XXX might want a ck_negate() for this */
2360 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2361 break;
de939608
CS		 2362 case OP_UCFIRST:
2363 case OP_LCFIRST:
2364 case OP_UC:
2365 case OP_LC:
69dcf70c
MB		 2366 case OP_SLT:
2367 case OP_SGT:
2368 case OP_SLE:
2369 case OP_SGE:
2370 case OP_SCMP:
2de3dbcc
JH		 2371 /* XXX what about the numeric ops? */
2372 if (PL_hints & HINT_LOCALE)
de939608
CS		 2373 goto nope;
2374 }
2375
3280af22 2376 if (PL_error_count)
a0d0e21e
LW		 2377 goto nope; /* Don't try to run w/ errors */
2378
79072805 2379 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 2380 const OPCODE type = curop->op_type;
2381 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2382 type != OP_LIST &&
2383 type != OP_SCALAR &&
2384 type != OP_NULL &&
2385 type != OP_PUSHMARK)
7a52d87a 2386 {
79072805
LW		 2387 goto nope;
2388 }
2389 }
2390
2391 curop = LINKLIST(o);
b7f7fd0b 2392 old_next = o->op_next;
79072805 2393 o->op_next = 0;
533c011a 2394 PL_op = curop;
b7f7fd0b
NC		 2395
2396 oldscope = PL_scopestack_ix;
edb2152a 2397 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 2398
5f2d9966
DM		 2399 PL_warnhook = PERL_WARNHOOK_FATAL;
2400 PL_diehook = NULL;
b7f7fd0b
NC		 2401 JMPENV_PUSH(ret);
2402
2403 switch (ret) {
2404 case 0:
2405 CALLRUNOPS(aTHX);
2406 sv = *(PL_stack_sp--);
2407 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2408 pad_swipe(o->op_targ, FALSE);
2409 else if (SvTEMP(sv)) { /* grab mortal temp? */
2410 SvREFCNT_inc_simple_void(sv);
2411 SvTEMP_off(sv);
2412 }
2413 break;
2414 case 3:
2415 /* Something tried to die. Abandon constant folding. */
2416 /* Pretend the error never happened. */
2417 sv_setpvn(ERRSV,"",0);
2418 o->op_next = old_next;
2419 break;
2420 default:
2421 JMPENV_POP;
5f2d9966
DM		 2422 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2423 PL_warnhook = oldwarnhook;
2424 PL_diehook = olddiehook;
2425 /* XXX note that this croak may fail as we've already blown away
2426 * the stack - eg any nested evals */
b7f7fd0b
NC		 2427 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2428 }
b7f7fd0b 2429 JMPENV_POP;
5f2d9966
DM		 2430 PL_warnhook = oldwarnhook;
2431 PL_diehook = olddiehook;
edb2152a
NC		 2432
2433 if (PL_scopestack_ix > oldscope)
2434 delete_eval_scope();
eb8433b7 2435
b7f7fd0b
NC		 2436 if (ret)
2437 goto nope;
2438
eb8433b7 2439#ifndef PERL_MAD
79072805 2440 op_free(o);
eb8433b7 2441#endif
de5e01c2 2442 assert(sv);
79072805 2443 if (type == OP_RV2GV)
eb8433b7
NC		 2444 newop = newGVOP(OP_GV, 0, (GV*)sv);
2445 else
670f1322 2446 newop = newSVOP(OP_CONST, 0, (SV*)sv);
eb8433b7
NC		 2447 op_getmad(o,newop,'f');
2448 return newop;
aeea060c 2449
b7f7fd0b 2450 nope:
79072805
LW		 2451 return o;
2452}
2453
2454OP *
864dbfa3 2455Perl_gen_constant_list(pTHX_ register OP *o)
79072805 2456{
27da23d5 2457 dVAR;
79072805 2458 register OP *curop;
6867be6d 2459 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2460
a0d0e21e 2461 list(o);
3280af22 2462 if (PL_error_count)
a0d0e21e
LW		 2463 return o; /* Don't attempt to run with errors */
2464
533c011a 2465 PL_op = curop = LINKLIST(o);
a0d0e21e 2466 o->op_next = 0;
a2efc822 2467 CALL_PEEP(curop);
cea2e8a9
GS		 2468 pp_pushmark();
2469 CALLRUNOPS(aTHX);
533c011a 2470 PL_op = curop;
78c72037
NC		 2471 assert (!(curop->op_flags & OPf_SPECIAL));
2472 assert(curop->op_type == OP_RANGE);
cea2e8a9 2473 pp_anonlist();
3280af22 2474 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2475
2476 o->op_type = OP_RV2AV;
22c35a8c 2477 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2478 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2479 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2480 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2481 curop = ((UNOP*)o)->op_first;
b37c2d43 2482 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 2483#ifdef PERL_MAD
2484 op_getmad(curop,o,'O');
2485#else
79072805 2486 op_free(curop);
eb8433b7 2487#endif
79072805
LW		 2488 linklist(o);
2489 return list(o);
2490}
2491
2492OP *
864dbfa3 2493Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2494{
27da23d5 2495 dVAR;
11343788 2496 if (!o || o->op_type != OP_LIST)
5f66b61c 2497 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 2498 else
5dc0d613 2499 o->op_flags &= ~OPf_WANT;
79072805 2500
22c35a8c 2501 if (!(PL_opargs[type] & OA_MARK))
93c66552 2502 op_null(cLISTOPo->op_first);
8990e307 2503
eb160463 2504 o->op_type = (OPCODE)type;
22c35a8c 2505 o->op_ppaddr = PL_ppaddr[type];
11343788 2506 o->op_flags |= flags;
79072805 2507
11343788 2508 o = CHECKOP(type, o);
fe2774ed 2509 if (o->op_type != (unsigned)type)
11343788 2510 return o;
79072805 2511
11343788 2512 return fold_constants(o);
79072805
LW		 2513}
2514
2515/* List constructors */
2516
2517OP *
864dbfa3 2518Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2519{
2520 if (!first)
2521 return last;
8990e307
LW		 2522
2523 if (!last)
79072805 2524 return first;
8990e307 2525
fe2774ed 2526 if (first->op_type != (unsigned)type
155aba94
GS		 2527 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2528 {
2529 return newLISTOP(type, 0, first, last);
2530 }
79072805 2531
a0d0e21e
LW		 2532 if (first->op_flags & OPf_KIDS)
2533 ((LISTOP*)first)->op_last->op_sibling = last;
2534 else {
2535 first->op_flags |= OPf_KIDS;
2536 ((LISTOP*)first)->op_first = last;
2537 }
2538 ((LISTOP*)first)->op_last = last;
a0d0e21e 2539 return first;
79072805
LW		 2540}
2541
2542OP *
864dbfa3 2543Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2544{
2545 if (!first)
2546 return (OP*)last;
8990e307
LW		 2547
2548 if (!last)
79072805 2549 return (OP*)first;
8990e307 2550
fe2774ed 2551 if (first->op_type != (unsigned)type)
79072805 2552 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2553
fe2774ed 2554 if (last->op_type != (unsigned)type)
79072805
LW		 2555 return append_elem(type, (OP*)first, (OP*)last);
2556
2557 first->op_last->op_sibling = last->op_first;
2558 first->op_last = last->op_last;
117dada2 2559 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2560
eb8433b7
NC		 2561#ifdef PERL_MAD
2562 if (last->op_first && first->op_madprop) {
2563 MADPROP *mp = last->op_first->op_madprop;
2564 if (mp) {
2565 while (mp->mad_next)
2566 mp = mp->mad_next;
2567 mp->mad_next = first->op_madprop;
2568 }
2569 else {
2570 last->op_first->op_madprop = first->op_madprop;
2571 }
2572 }
2573 first->op_madprop = last->op_madprop;
2574 last->op_madprop = 0;
2575#endif
2576
d2c837a0 2577 S_op_destroy(aTHX_ (OP*)last);
238a4c30 2578
79072805
LW		 2579 return (OP*)first;
2580}
2581
2582OP *
864dbfa3 2583Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2584{
2585 if (!first)
2586 return last;
8990e307
LW		 2587
2588 if (!last)
79072805 2589 return first;
8990e307 2590
fe2774ed 2591 if (last->op_type == (unsigned)type) {
8990e307
LW		 2592 if (type == OP_LIST) { /* already a PUSHMARK there */
2593 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2594 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2595 if (!(first->op_flags & OPf_PARENS))
2596 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2597 }
2598 else {
2599 if (!(last->op_flags & OPf_KIDS)) {
2600 ((LISTOP*)last)->op_last = first;
2601 last->op_flags |= OPf_KIDS;
2602 }
2603 first->op_sibling = ((LISTOP*)last)->op_first;
2604 ((LISTOP*)last)->op_first = first;
79072805 2605 }
117dada2 2606 last->op_flags |= OPf_KIDS;
79072805
LW		 2607 return last;
2608 }
2609
2610 return newLISTOP(type, 0, first, last);
2611}
2612
2613/* Constructors */
2614
eb8433b7
NC		 2615#ifdef PERL_MAD
2616
2617TOKEN *
2618Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2619{
2620 TOKEN *tk;
99129197 2621 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 2622 tk->tk_type = (OPCODE)optype;
2623 tk->tk_type = 12345;
2624 tk->tk_lval = lval;
2625 tk->tk_mad = madprop;
2626 return tk;
2627}
2628
2629void
2630Perl_token_free(pTHX_ TOKEN* tk)
2631{
2632 if (tk->tk_type != 12345)
2633 return;
2634 mad_free(tk->tk_mad);
2635 Safefree(tk);
2636}
2637
2638void
2639Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2640{
2641 MADPROP* mp;
2642 MADPROP* tm;
2643 if (tk->tk_type != 12345) {
2644 Perl_warner(aTHX_ packWARN(WARN_MISC),
2645 "Invalid TOKEN object ignored");
2646 return;
2647 }
2648 tm = tk->tk_mad;
2649 if (!tm)
2650 return;
2651
2652 /* faked up qw list? */
2653 if (slot == '(' &&
2654 tm->mad_type == MAD_SV &&
2655 SvPVX((SV*)tm->mad_val)[0] == 'q')
2656 slot = 'x';
2657
2658 if (o) {
2659 mp = o->op_madprop;
2660 if (mp) {
2661 for (;;) {
2662 /* pretend constant fold didn't happen? */
2663 if (mp->mad_key == 'f' &&
2664 (o->op_type == OP_CONST ||
2665 o->op_type == OP_GV) )
2666 {
2667 token_getmad(tk,(OP*)mp->mad_val,slot);
2668 return;
2669 }
2670 if (!mp->mad_next)
2671 break;
2672 mp = mp->mad_next;
2673 }
2674 mp->mad_next = tm;
2675 mp = mp->mad_next;
2676 }
2677 else {
2678 o->op_madprop = tm;
2679 mp = o->op_madprop;
2680 }
2681 if (mp->mad_key == 'X')
2682 mp->mad_key = slot; /* just change the first one */
2683
2684 tk->tk_mad = 0;
2685 }
2686 else
2687 mad_free(tm);
2688 Safefree(tk);
2689}
2690
2691void
2692Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2693{
2694 MADPROP* mp;
2695 if (!from)
2696 return;
2697 if (o) {
2698 mp = o->op_madprop;
2699 if (mp) {
2700 for (;;) {
2701 /* pretend constant fold didn't happen? */
2702 if (mp->mad_key == 'f' &&
2703 (o->op_type == OP_CONST ||
2704 o->op_type == OP_GV) )
2705 {
2706 op_getmad(from,(OP*)mp->mad_val,slot);
2707 return;
2708 }
2709 if (!mp->mad_next)
2710 break;
2711 mp = mp->mad_next;
2712 }
2713 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2714 }
2715 else {
2716 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2717 }
2718 }
2719}
2720
2721void
2722Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2723{
2724 MADPROP* mp;
2725 if (!from)
2726 return;
2727 if (o) {
2728 mp = o->op_madprop;
2729 if (mp) {
2730 for (;;) {
2731 /* pretend constant fold didn't happen? */
2732 if (mp->mad_key == 'f' &&
2733 (o->op_type == OP_CONST ||
2734 o->op_type == OP_GV) )
2735 {
2736 op_getmad(from,(OP*)mp->mad_val,slot);
2737 return;
2738 }
2739 if (!mp->mad_next)
2740 break;
2741 mp = mp->mad_next;
2742 }
2743 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2744 }
2745 else {
2746 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2747 }
2748 }
2749 else {
99129197
NC		 2750 PerlIO_printf(PerlIO_stderr(),
2751 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 2752 op_free(from);
2753 }
2754}
2755
2756void
2757Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2758{
2759 MADPROP* tm;
2760 if (!mp || !o)
2761 return;
2762 if (slot)
2763 mp->mad_key = slot;
2764 tm = o->op_madprop;
2765 o->op_madprop = mp;
2766 for (;;) {
2767 if (!mp->mad_next)
2768 break;
2769 mp = mp->mad_next;
2770 }
2771 mp->mad_next = tm;
2772}
2773
2774void
2775Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2776{
2777 if (!o)
2778 return;
2779 addmad(tm, &(o->op_madprop), slot);
2780}
2781
2782void
2783Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2784{
2785 MADPROP* mp;
2786 if (!tm || !root)
2787 return;
2788 if (slot)
2789 tm->mad_key = slot;
2790 mp = *root;
2791 if (!mp) {
2792 *root = tm;
2793 return;
2794 }
2795 for (;;) {
2796 if (!mp->mad_next)
2797 break;
2798 mp = mp->mad_next;
2799 }
2800 mp->mad_next = tm;
2801}
2802
2803MADPROP *
2804Perl_newMADsv(pTHX_ char key, SV* sv)
2805{
2806 return newMADPROP(key, MAD_SV, sv, 0);
2807}
2808
2809MADPROP *
2810Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2811{
2812 MADPROP *mp;
99129197 2813 Newxz(mp, 1, MADPROP);
eb8433b7
NC		 2814 mp->mad_next = 0;
2815 mp->mad_key = key;
2816 mp->mad_vlen = vlen;
2817 mp->mad_type = type;
2818 mp->mad_val = val;
2819/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2820 return mp;
2821}
2822
2823void
2824Perl_mad_free(pTHX_ MADPROP* mp)
2825{
2826/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2827 if (!mp)
2828 return;
2829 if (mp->mad_next)
2830 mad_free(mp->mad_next);
bc177e6b 2831/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC		 2832 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2833 switch (mp->mad_type) {
2834 case MAD_NULL:
2835 break;
2836 case MAD_PV:
2837 Safefree((char*)mp->mad_val);
2838 break;
2839 case MAD_OP:
2840 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2841 op_free((OP*)mp->mad_val);
2842 break;
2843 case MAD_SV:
2844 sv_free((SV*)mp->mad_val);
2845 break;
2846 default:
2847 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2848 break;
2849 }
2850 Safefree(mp);
2851}
2852
2853#endif
2854
79072805 2855OP *
864dbfa3 2856Perl_newNULLLIST(pTHX)
79072805 2857{
8990e307
LW		 2858 return newOP(OP_STUB, 0);
2859}
2860
2861OP *
864dbfa3 2862Perl_force_list(pTHX_ OP *o)
8990e307 2863{
11343788 2864 if (!o || o->op_type != OP_LIST)
5f66b61c 2865 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 2866 op_null(o);
11343788 2867 return o;
79072805
LW		 2868}
2869
2870OP *
864dbfa3 2871Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2872{
27da23d5 2873 dVAR;
79072805
LW		 2874 LISTOP *listop;
2875
b7dc083c 2876 NewOp(1101, listop, 1, LISTOP);
79072805 2877
eb160463 2878 listop->op_type = (OPCODE)type;
22c35a8c 2879 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2880 if (first || last)
2881 flags |= OPf_KIDS;
eb160463 2882 listop->op_flags = (U8)flags;
79072805
LW		 2883
2884 if (!last && first)
2885 last = first;
2886 else if (!first && last)
2887 first = last;
8990e307
LW		 2888 else if (first)
2889 first->op_sibling = last;
79072805
LW		 2890 listop->op_first = first;
2891 listop->op_last = last;
8990e307 2892 if (type == OP_LIST) {
551405c4 2893 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 2894 pushop->op_sibling = first;
2895 listop->op_first = pushop;
2896 listop->op_flags |= OPf_KIDS;
2897 if (!last)
2898 listop->op_last = pushop;
2899 }
79072805 2900
463d09e6 2901 return CHECKOP(type, listop);
79072805
LW		 2902}
2903
2904OP *
864dbfa3 2905Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2906{
27da23d5 2907 dVAR;
11343788 2908 OP *o;
b7dc083c 2909 NewOp(1101, o, 1, OP);
eb160463 2910 o->op_type = (OPCODE)type;
22c35a8c 2911 o->op_ppaddr = PL_ppaddr[type];
eb160463 2912 o->op_flags = (U8)flags;
670f3923
DM		 2913 o->op_latefree = 0;
2914 o->op_latefreed = 0;
7e5d8ed2 2915 o->op_attached = 0;
79072805 2916
11343788 2917 o->op_next = o;
eb160463 2918 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2919 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2920 scalar(o);
22c35a8c 2921 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2922 o->op_targ = pad_alloc(type, SVs_PADTMP);
2923 return CHECKOP(type, o);
79072805
LW		 2924}
2925
2926OP *
864dbfa3 2927Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 2928{
27da23d5 2929 dVAR;
79072805
LW		 2930 UNOP *unop;
2931
93a17b20 2932 if (!first)
aeea060c 2933 first = newOP(OP_STUB, 0);
22c35a8c 2934 if (PL_opargs[type] & OA_MARK)
8990e307 2935 first = force_list(first);
93a17b20 2936
b7dc083c 2937 NewOp(1101, unop, 1, UNOP);
eb160463 2938 unop->op_type = (OPCODE)type;
22c35a8c 2939 unop->op_ppaddr = PL_ppaddr[type];
79072805 2940 unop->op_first = first;
585ec06d 2941 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 2942 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2943 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2944 if (unop->op_next)
2945 return (OP*)unop;
2946
a0d0e21e 2947 return fold_constants((OP *) unop);
79072805
LW		 2948}
2949
2950OP *
864dbfa3 2951Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2952{
27da23d5 2953 dVAR;
79072805 2954 BINOP *binop;
b7dc083c 2955 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2956
2957 if (!first)
2958 first = newOP(OP_NULL, 0);
2959
eb160463 2960 binop->op_type = (OPCODE)type;
22c35a8c 2961 binop->op_ppaddr = PL_ppaddr[type];
79072805 2962 binop->op_first = first;
585ec06d 2963 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 2964 if (!last) {
2965 last = first;
eb160463 2966 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2967 }
2968 else {
eb160463 2969 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2970 first->op_sibling = last;
2971 }
2972
e50aee73 2973 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2974 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2975 return (OP*)binop;
2976
7284ab6f 2977 binop->op_last = binop->op_first->op_sibling;
79072805 2978
a0d0e21e 2979 return fold_constants((OP *)binop);
79072805
LW		 2980}
2981
5f66b61c
AL		 2982static int uvcompare(const void *a, const void *b)
2983 __attribute__nonnull__(1)
2984 __attribute__nonnull__(2)
2985 __attribute__pure__;
abb2c242 2986static int uvcompare(const void *a, const void *b)
2b9d42f0 2987{
e1ec3a88 2988 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 2989 return -1;
e1ec3a88 2990 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 2991 return 1;
e1ec3a88 2992 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 2993 return -1;
e1ec3a88 2994 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 2995 return 1;
a0ed51b3
LW		 2996 return 0;
2997}
2998
79072805 2999OP *
864dbfa3 3000Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 3001{
97aff369 3002 dVAR;
2d03de9c 3003 SV * const tstr = ((SVOP*)expr)->op_sv;
fbbb0949
DM		 3004 SV * const rstr =
3005#ifdef PERL_MAD
3006 (repl->op_type == OP_NULL)
3007 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3008#endif
3009 ((SVOP*)repl)->op_sv;
463ee0b2
LW		 3010 STRLEN tlen;
3011 STRLEN rlen;
5c144d81
NC		 3012 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3013 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 3014 register I32 i;
3015 register I32 j;
9b877dbb 3016 I32 grows = 0;
79072805
LW		 3017 register short *tbl;
3018
551405c4
AL		 3019 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3020 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3021 I32 del = o->op_private & OPpTRANS_DELETE;
043e41b8 3022 SV* swash;
800b4dc4 3023 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 3024
036b4402
GS		 3025 if (SvUTF8(tstr))
3026 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 3027
3028 if (SvUTF8(rstr))
036b4402 3029 o->op_private |= OPpTRANS_TO_UTF;
79072805 3030
a0ed51b3 3031 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 3032 SV* const listsv = newSVpvs("# comment\n");
c445ea15 3033 SV* transv = NULL;
5c144d81
NC		 3034 const U8* tend = t + tlen;
3035 const U8* rend = r + rlen;
ba210ebe 3036 STRLEN ulen;
84c133a0
RB		 3037 UV tfirst = 1;
3038 UV tlast = 0;
3039 IV tdiff;
3040 UV rfirst = 1;
3041 UV rlast = 0;
3042 IV rdiff;
3043 IV diff;
a0ed51b3
LW		 3044 I32 none = 0;
3045 U32 max = 0;
3046 I32 bits;
a0ed51b3 3047 I32 havefinal = 0;
9c5ffd7c 3048 U32 final = 0;
551405c4
AL		 3049 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3050 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 3051 U8* tsave = NULL;
3052 U8* rsave = NULL;
9f7f3913 3053 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 3054
3055 if (!from_utf) {
3056 STRLEN len = tlen;
5c144d81 3057 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 3058 tend = t + len;
3059 }
3060 if (!to_utf && rlen) {
3061 STRLEN len = rlen;
5c144d81 3062 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 3063 rend = r + len;
3064 }
a0ed51b3 3065
2b9d42f0
NIS		 3066/* There are several snags with this code on EBCDIC:
3067 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3068 2. scan_const() in toke.c has encoded chars in native encoding which makes
3069 ranges at least in EBCDIC 0..255 range the bottom odd.
3070*/
3071
a0ed51b3 3072 if (complement) {
89ebb4a3 3073 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 3074 UV *cp;
a0ed51b3 3075 UV nextmin = 0;
a02a5408 3076 Newx(cp, 2*tlen, UV);
a0ed51b3 3077 i = 0;
396482e1 3078 transv = newSVpvs("");
a0ed51b3 3079 while (t < tend) {
9f7f3913 3080 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS		 3081 t += ulen;
3082 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 3083 t++;
9f7f3913 3084 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 3085 t += ulen;
a0ed51b3 3086 }
2b9d42f0
NIS		 3087 else {
3088 cp[2*i+1] = cp[2*i];
3089 }
3090 i++;
a0ed51b3 3091 }
2b9d42f0 3092 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 3093 for (j = 0; j < i; j++) {
2b9d42f0 3094 UV val = cp[2*j];
a0ed51b3
LW		 3095 diff = val - nextmin;
3096 if (diff > 0) {
9041c2e3 3097 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3098 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 3099 if (diff > 1) {
2b9d42f0 3100 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 3101 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 3102 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 3103 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 3104 }
3105 }
2b9d42f0 3106 val = cp[2*j+1];
a0ed51b3
LW		 3107 if (val >= nextmin)
3108 nextmin = val + 1;
3109 }
9041c2e3 3110 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3111 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 3112 {
3113 U8 range_mark = UTF_TO_NATIVE(0xff);
3114 sv_catpvn(transv, (char *)&range_mark, 1);
3115 }
b851fbc1
JH		 3116 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3117 UNICODE_ALLOW_SUPER);
dfe13c55 3118 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 3119 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 3120 tlen = SvCUR(transv);
3121 tend = t + tlen;
455d824a 3122 Safefree(cp);
a0ed51b3
LW		 3123 }
3124 else if (!rlen && !del) {
3125 r = t; rlen = tlen; rend = tend;
4757a243
LW		 3126 }
3127 if (!squash) {
05d340b8 3128 if ((!rlen && !del) || t == r ||
12ae5dfc 3129 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 3130 {
4757a243 3131 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 3132 }
a0ed51b3
LW		 3133 }
3134
3135 while (t < tend || tfirst <= tlast) {
3136 /* see if we need more "t" chars */
3137 if (tfirst > tlast) {
9f7f3913 3138 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 3139 t += ulen;
2b9d42f0 3140 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3141 t++;
9f7f3913 3142 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW		 3143 t += ulen;
3144 }
3145 else
3146 tlast = tfirst;
3147 }
3148
3149 /* now see if we need more "r" chars */
3150 if (rfirst > rlast) {
3151 if (r < rend) {
9f7f3913 3152 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 3153 r += ulen;
2b9d42f0 3154 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3155 r++;
9f7f3913 3156 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW		 3157 r += ulen;
3158 }
3159 else
3160 rlast = rfirst;
3161 }
3162 else {
3163 if (!havefinal++)
3164 final = rlast;
3165 rfirst = rlast = 0xffffffff;
3166 }
3167 }
3168
3169 /* now see which range will peter our first, if either. */
3170 tdiff = tlast - tfirst;
3171 rdiff = rlast - rfirst;
3172
3173 if (tdiff <= rdiff)
3174 diff = tdiff;
3175 else
3176 diff = rdiff;
3177
3178 if (rfirst == 0xffffffff) {
3179 diff = tdiff; /* oops, pretend rdiff is infinite */
3180 if (diff > 0)
894356b3
GS		 3181 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3182 (long)tfirst, (long)tlast);
a0ed51b3 3183 else
894356b3 3184 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 3185 }
3186 else {
3187 if (diff > 0)
894356b3
GS		 3188 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3189 (long)tfirst, (long)(tfirst + diff),
3190 (long)rfirst);
a0ed51b3 3191 else
894356b3
GS		 3192 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3193 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 3194
3195 if (rfirst + diff > max)
3196 max = rfirst + diff;
9b877dbb 3197 if (!grows)
45005bfb
JH		 3198 grows = (tfirst < rfirst &&
3199 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3200 rfirst += diff + 1;
a0ed51b3
LW		 3201 }
3202 tfirst += diff + 1;
3203 }
3204
3205 none = ++max;
3206 if (del)
3207 del = ++max;
3208
3209 if (max > 0xffff)
3210 bits = 32;
3211 else if (max > 0xff)
3212 bits = 16;
3213 else
3214 bits = 8;
3215
ea71c68d 3216 PerlMemShared_free(cPVOPo->op_pv);
b3123a61 3217 cPVOPo->op_pv = NULL;
043e41b8
DM		 3218
3219 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3220#ifdef USE_ITHREADS
3221 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3222 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3223 PAD_SETSV(cPADOPo->op_padix, swash);
3224 SvPADTMP_on(swash);
3225#else
3226 cSVOPo->op_sv = swash;
3227#endif
a0ed51b3 3228 SvREFCNT_dec(listsv);
b37c2d43 3229 SvREFCNT_dec(transv);
a0ed51b3 3230
45005bfb 3231 if (!del && havefinal && rlen)
043e41b8 3232 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
b448e4fe 3233 newSVuv((UV)final), 0);
a0ed51b3 3234
9b877dbb 3235 if (grows)
a0ed51b3
LW		 3236 o->op_private |= OPpTRANS_GROWS;
3237
b37c2d43
AL		 3238 Safefree(tsave);
3239 Safefree(rsave);
9b877dbb 3240
eb8433b7
NC		 3241#ifdef PERL_MAD
3242 op_getmad(expr,o,'e');
3243 op_getmad(repl,o,'r');
3244#else
a0ed51b3
LW		 3245 op_free(expr);
3246 op_free(repl);
eb8433b7 3247#endif
a0ed51b3
LW		 3248 return o;
3249 }
3250
3251 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 3252 if (complement) {
3253 Zero(tbl, 256, short);
eb160463 3254 for (i = 0; i < (I32)tlen; i++)
ec49126f 3255 tbl[t[i]] = -1;
79072805
LW		 3256 for (i = 0, j = 0; i < 256; i++) {
3257 if (!tbl[i]) {
eb160463 3258 if (j >= (I32)rlen) {
a0ed51b3 3259 if (del)
79072805
LW		 3260 tbl[i] = -2;
3261 else if (rlen)
ec49126f 3262 tbl[i] = r[j-1];
79072805 3263 else
eb160463 3264 tbl[i] = (short)i;
79072805 3265 }
9b877dbb
IH		 3266 else {
3267 if (i < 128 && r[j] >= 128)
3268 grows = 1;
ec49126f 3269 tbl[i] = r[j++];
9b877dbb 3270 }
79072805
LW		 3271 }
3272 }
05d340b8
JH		 3273 if (!del) {
3274 if (!rlen) {
3275 j = rlen;
3276 if (!squash)
3277 o->op_private |= OPpTRANS_IDENTICAL;
3278 }
eb160463 3279 else if (j >= (I32)rlen)
05d340b8 3280 j = rlen - 1;
10db182f 3281 else {
aa1f7c5b
JH		 3282 tbl =
3283 (short *)
3284 PerlMemShared_realloc(tbl,
3285 (0x101+rlen-j) * sizeof(short));
10db182f
YO		 3286 cPVOPo->op_pv = (char*)tbl;
3287 }
585ec06d 3288 tbl[0x100] = (short)(rlen - j);
eb160463 3289 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 3290 tbl[0x101+i] = r[j+i];
3291 }
79072805
LW		 3292 }
3293 else {
a0ed51b3 3294 if (!rlen && !del) {
79072805 3295 r = t; rlen = tlen;
5d06d08e 3296 if (!squash)
4757a243 3297 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3298 }
94bfe852
RGS		 3299 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3300 o->op_private |= OPpTRANS_IDENTICAL;
3301 }
79072805
LW		 3302 for (i = 0; i < 256; i++)
3303 tbl[i] = -1;
eb160463
GS		 3304 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3305 if (j >= (I32)rlen) {
a0ed51b3 3306 if (del) {
ec49126f 3307 if (tbl[t[i]] == -1)
3308 tbl[t[i]] = -2;
79072805
LW		 3309 continue;
3310 }
3311 --j;
3312 }
9b877dbb
IH		 3313 if (tbl[t[i]] == -1) {
3314 if (t[i] < 128 && r[j] >= 128)
3315 grows = 1;
ec49126f 3316 tbl[t[i]] = r[j];
9b877dbb 3317 }
79072805
LW		 3318 }
3319 }
9b877dbb
IH		 3320 if (grows)
3321 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 3322#ifdef PERL_MAD
3323 op_getmad(expr,o,'e');
3324 op_getmad(repl,o,'r');
3325#else
79072805
LW		 3326 op_free(expr);
3327 op_free(repl);
eb8433b7 3328#endif
79072805 3329
11343788 3330 return o;
79072805
LW		 3331}
3332
3333OP *
864dbfa3 3334Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 3335{
27da23d5 3336 dVAR;
79072805
LW		 3337 PMOP *pmop;
3338
b7dc083c 3339 NewOp(1101, pmop, 1, PMOP);
eb160463 3340 pmop->op_type = (OPCODE)type;
22c35a8c 3341 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 3342 pmop->op_flags = (U8)flags;
3343 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 3344
3280af22 3345 if (PL_hints & HINT_RE_TAINT)
c737faaf 3346 pmop->op_pmflags |= PMf_RETAINT;
3280af22 3347 if (PL_hints & HINT_LOCALE)
c737faaf
YO		 3348 pmop->op_pmflags |= PMf_LOCALE;
3349
36477c24 3350
debc9467 3351#ifdef USE_ITHREADS
551405c4
AL		 3352 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3353 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3354 pmop->op_pmoffset = SvIV(repointer);
3355 SvREPADTMP_off(repointer);
3356 sv_setiv(repointer,0);
3357 } else {
3358 SV * const repointer = newSViv(0);
b37c2d43 3359 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
551405c4
AL		 3360 pmop->op_pmoffset = av_len(PL_regex_padav);
3361 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 3362 }
debc9467 3363#endif
1eb1540c 3364
463d09e6 3365 return CHECKOP(type, pmop);
79072805
LW		 3366}
3367
131b3ad0
DM		 3368/* Given some sort of match op o, and an expression expr containing a
3369 * pattern, either compile expr into a regex and attach it to o (if it's
3370 * constant), or convert expr into a runtime regcomp op sequence (if it's
3371 * not)
3372 *
3373 * isreg indicates that the pattern is part of a regex construct, eg
3374 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3375 * split "pattern", which aren't. In the former case, expr will be a list
3376 * if the pattern contains more than one term (eg /a$b/) or if it contains
3377 * a replacement, ie s/// or tr///.
3378 */
3379
79072805 3380OP *
131b3ad0 3381Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 3382{
27da23d5 3383 dVAR;
79072805
LW		 3384 PMOP *pm;
3385 LOGOP *rcop;
ce862d02 3386 I32 repl_has_vars = 0;
5f66b61c 3387 OP* repl = NULL;
131b3ad0
DM		 3388 bool reglist;
3389
3390 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3391 /* last element in list is the replacement; pop it */
3392 OP* kid;
3393 repl = cLISTOPx(expr)->op_last;
3394 kid = cLISTOPx(expr)->op_first;
3395 while (kid->op_sibling != repl)
3396 kid = kid->op_sibling;
5f66b61c 3397 kid->op_sibling = NULL;
131b3ad0
DM		 3398 cLISTOPx(expr)->op_last = kid;
3399 }
79072805 3400
131b3ad0
DM		 3401 if (isreg && expr->op_type == OP_LIST &&
3402 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3403 {
3404 /* convert single element list to element */
0bd48802 3405 OP* const oe = expr;
131b3ad0 3406 expr = cLISTOPx(oe)->op_first->op_sibling;
5f66b61c
AL		 3407 cLISTOPx(oe)->op_first->op_sibling = NULL;
3408 cLISTOPx(oe)->op_last = NULL;
131b3ad0
DM		 3409 op_free(oe);
3410 }
3411
3412 if (o->op_type == OP_TRANS) {
11343788 3413 return pmtrans(o, expr, repl);
131b3ad0
DM		 3414 }
3415
3416 reglist = isreg && expr->op_type == OP_LIST;
3417 if (reglist)
3418 op_null(expr);
79072805 3419
3280af22 3420 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3421 pm = (PMOP*)o;
79072805
LW		 3422
3423 if (expr->op_type == OP_CONST) {
463ee0b2 3424 STRLEN plen;
6136c704 3425 SV * const pat = ((SVOP*)expr)->op_sv;
5c144d81 3426 const char *p = SvPV_const(pat, plen);
c737faaf 3427 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
ede8ac17 3428 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
5c144d81
NC		 3429 U32 was_readonly = SvREADONLY(pat);
3430
3431 if (was_readonly) {
3432 if (SvFAKE(pat)) {
3433 sv_force_normal_flags(pat, 0);
3434 assert(!SvREADONLY(pat));
3435 was_readonly = 0;
3436 } else {
3437 SvREADONLY_off(pat);
3438 }
3439 }
3440
93a17b20 3441 sv_setpvn(pat, "\\s+", 3);
5c144d81
NC		 3442
3443 SvFLAGS(pat) |= was_readonly;
3444
3445 p = SvPV_const(pat, plen);
c737faaf 3446 pm_flags |= RXf_SKIPWHITE;
79072805 3447 }
5b71a6a7 3448 if (DO_UTF8(pat))
c737faaf 3449 pm_flags |= RXf_UTF8;
3ab4a224 3450 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
c737faaf 3451
eb8433b7
NC		 3452#ifdef PERL_MAD
3453 op_getmad(expr,(OP*)pm,'e');
3454#else
79072805 3455 op_free(expr);
eb8433b7 3456#endif
79072805
LW		 3457 }
3458 else {
3280af22 3459 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3460 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3461 ? OP_REGCRESET
3462 : OP_REGCMAYBE),0,expr);
463ee0b2 3463
b7dc083c 3464 NewOp(1101, rcop, 1, LOGOP);
79072805 3465 rcop->op_type = OP_REGCOMP;
22c35a8c 3466 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3467 rcop->op_first = scalar(expr);
131b3ad0
DM		 3468 rcop->op_flags |= OPf_KIDS
3469 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3470 | (reglist ? OPf_STACKED : 0);
79072805 3471 rcop->op_private = 1;
11343788 3472 rcop->op_other = o;
131b3ad0
DM		 3473 if (reglist)
3474 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3475
b5c19bd7
DM		 3476 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3477 PL_cv_has_eval = 1;
79072805
LW		 3478
3479 /* establish postfix order */
3280af22 3480 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3481 LINKLIST(expr);
3482 rcop->op_next = expr;
3483 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3484 }
3485 else {
3486 rcop->op_next = LINKLIST(expr);
3487 expr->op_next = (OP*)rcop;
3488 }
79072805 3489
11343788 3490 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3491 }
3492
3493 if (repl) {
748a9306 3494 OP *curop;
0244c3a4 3495 if (pm->op_pmflags & PMf_EVAL) {
6136c704 3496 curop = NULL;
670a9cb2
DM		 3497 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3498 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
0244c3a4 3499 }
748a9306
LW		 3500 else if (repl->op_type == OP_CONST)
3501 curop = repl;
79072805 3502 else {
c445ea15 3503 OP *lastop = NULL;
79072805 3504 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
e80b829c 3505 if (curop->op_type == OP_SCOPE
10250113 3506 || curop->op_type == OP_LEAVE
e80b829c 3507 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
79072805 3508 if (curop->op_type == OP_GV) {
6136c704 3509 GV * const gv = cGVOPx_gv(curop);
ce862d02 3510 repl_has_vars = 1;
f702bf4a 3511 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 3512 break;
3513 }
3514 else if (curop->op_type == OP_RV2CV)
3515 break;
3516 else if (curop->op_type == OP_RV2SV ||
3517 curop->op_type == OP_RV2AV ||
3518 curop->op_type == OP_RV2HV ||
3519 curop->op_type == OP_RV2GV) {
3520 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3521 break;
3522 }
748a9306
LW		 3523 else if (curop->op_type == OP_PADSV ||
3524 curop->op_type == OP_PADAV ||
3525 curop->op_type == OP_PADHV ||
e80b829c
RGS		 3526 curop->op_type == OP_PADANY)
3527 {
ce862d02 3528 repl_has_vars = 1;
748a9306 3529 }
1167e5da 3530 else if (curop->op_type == OP_PUSHRE)
6f207bd3 3531 NOOP; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3532 else
3533 break;
3534 }
3535 lastop = curop;
3536 }
748a9306 3537 }
ce862d02 3538 if (curop == repl
e80b829c
RGS		 3539 && !(repl_has_vars
3540 && (!PM_GETRE(pm)
3541 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3be69782 3542 {
748a9306 3543 pm->op_pmflags |= PMf_CONST; /* const for long enough */
11343788 3544 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3545 }
3546 else {
aaa362c4 3547 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02 3548 pm->op_pmflags |= PMf_MAYBE_CONST;
ce862d02 3549 }
b7dc083c 3550 NewOp(1101, rcop, 1, LOGOP);
748a9306 3551 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3552 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3553 rcop->op_first = scalar(repl);
3554 rcop->op_flags |= OPf_KIDS;
3555 rcop->op_private = 1;
11343788 3556 rcop->op_other = o;
748a9306
LW		 3557
3558 /* establish postfix order */
3559 rcop->op_next = LINKLIST(repl);
3560 repl->op_next = (OP*)rcop;
3561
20e98b0f 3562 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
29f2e912
NC		 3563 assert(!(pm->op_pmflags & PMf_ONCE));
3564 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
748a9306 3565 rcop->op_next = 0;
79072805
LW		 3566 }
3567 }
3568
3569 return (OP*)pm;
3570}
3571
3572OP *
864dbfa3 3573Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 3574{
27da23d5 3575