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