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