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