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