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