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