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