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