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