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