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