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