This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Macroify the block_hooks structure.
[perl5.git] / op.c
CommitLineData
4b88f280 1#line 2 "op.c"
a0d0e21e 2/* op.c
79072805 3 *
1129b882
NC
4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805
LW
6 *
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
9 *
a0d0e21e
LW
10 */
11
12/*
4ac71550
TC
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
18 *
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
79072805
LW
20 */
21
166f8a29
DM
22/* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
24 *
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
31 * stack.
32 *
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
37 *
38 * newBINOP(OP_ADD, flags,
39 * newSVREF($a),
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41 * )
42 *
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
45 */
ccfc67b7 46
61b743bb
DM
47/*
48Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49
50 A bottom-up pass
51 A top-down pass
52 An execution-order pass
53
54The bottom-up pass is represented by all the "newOP" routines and
55the ck_ routines. The bottom-upness is actually driven by yacc.
56So at the point that a ck_ routine fires, we have no idea what the
57context is, either upward in the syntax tree, or either forward or
58backward in the execution order. (The bottom-up parser builds that
59part of the execution order it knows about, but if you follow the "next"
60links around, you'll find it's actually a closed loop through the
ef9da979 61top level node.)
61b743bb
DM
62
63Whenever the bottom-up parser gets to a node that supplies context to
64its components, it invokes that portion of the top-down pass that applies
65to that part of the subtree (and marks the top node as processed, so
66if a node further up supplies context, it doesn't have to take the
67plunge again). As a particular subcase of this, as the new node is
68built, it takes all the closed execution loops of its subcomponents
69and links them into a new closed loop for the higher level node. But
70it's still not the real execution order.
71
72The actual execution order is not known till we get a grammar reduction
73to a top-level unit like a subroutine or file that will be called by
74"name" rather than via a "next" pointer. At that point, we can call
75into peep() to do that code's portion of the 3rd pass. It has to be
76recursive, but it's recursive on basic blocks, not on tree nodes.
77*/
78
06e0342d 79/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
06e0342d 87 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
91
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
34795b44 96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
c28fe1ec
NC
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC
99*/
100
79072805 101#include "EXTERN.h"
864dbfa3 102#define PERL_IN_OP_C
79072805 103#include "perl.h"
77ca0c92 104#include "keywords.h"
79072805 105
a07e034d 106#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
f37b8c3f 107#define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
a2efc822 108
238a4c30
NIS
109#if defined(PL_OP_SLAB_ALLOC)
110
f1fac472
NC
111#ifdef PERL_DEBUG_READONLY_OPS
112# define PERL_SLAB_SIZE 4096
113# include <sys/mman.h>
114#endif
115
238a4c30
NIS
116#ifndef PERL_SLAB_SIZE
117#define PERL_SLAB_SIZE 2048
118#endif
119
c7e45529 120void *
e91d68d5 121Perl_Slab_Alloc(pTHX_ size_t sz)
1c846c1f 122{
5186cc12 123 dVAR;
5a8e194f
NIS
124 /*
125 * To make incrementing use count easy PL_OpSlab is an I32 *
126 * To make inserting the link to slab PL_OpPtr is I32 **
127 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
128 * Add an overhead for pointer to slab and round up as a number of pointers
129 */
130 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 131 if ((PL_OpSpace -= sz) < 0) {
f1fac472
NC
132#ifdef PERL_DEBUG_READONLY_OPS
133 /* We need to allocate chunk by chunk so that we can control the VM
134 mapping */
5186cc12 135 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
f1fac472
NC
136 MAP_ANON|MAP_PRIVATE, -1, 0);
137
138 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
139 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
140 PL_OpPtr));
141 if(PL_OpPtr == MAP_FAILED) {
142 perror("mmap failed");
143 abort();
144 }
145#else
277e868c
NC
146
147 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
f1fac472 148#endif
083fcd59 149 if (!PL_OpPtr) {
238a4c30
NIS
150 return NULL;
151 }
5a8e194f
NIS
152 /* We reserve the 0'th I32 sized chunk as a use count */
153 PL_OpSlab = (I32 *) PL_OpPtr;
154 /* Reduce size by the use count word, and by the size we need.
155 * Latter is to mimic the '-=' in the if() above
156 */
157 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS
158 /* Allocation pointer starts at the top.
159 Theory: because we build leaves before trunk allocating at end
160 means that at run time access is cache friendly upward
161 */
5a8e194f 162 PL_OpPtr += PERL_SLAB_SIZE;
f1fac472
NC
163
164#ifdef PERL_DEBUG_READONLY_OPS
165 /* We remember this slab. */
166 /* This implementation isn't efficient, but it is simple. */
5186cc12 167 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
f1fac472
NC
168 PL_slabs[PL_slab_count++] = PL_OpSlab;
169 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
170#endif
238a4c30
NIS
171 }
172 assert( PL_OpSpace >= 0 );
173 /* Move the allocation pointer down */
174 PL_OpPtr -= sz;
5a8e194f 175 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS
176 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
177 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 178 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS
179 assert( *PL_OpSlab > 0 );
180 return (void *)(PL_OpPtr + 1);
181}
182
f1fac472
NC
183#ifdef PERL_DEBUG_READONLY_OPS
184void
185Perl_pending_Slabs_to_ro(pTHX) {
186 /* Turn all the allocated op slabs read only. */
187 U32 count = PL_slab_count;
188 I32 **const slabs = PL_slabs;
189
190 /* Reset the array of pending OP slabs, as we're about to turn this lot
191 read only. Also, do it ahead of the loop in case the warn triggers,
192 and a warn handler has an eval */
193
f1fac472
NC
194 PL_slabs = NULL;
195 PL_slab_count = 0;
196
197 /* Force a new slab for any further allocation. */
198 PL_OpSpace = 0;
199
200 while (count--) {
5892a4d4 201 void *const start = slabs[count];
f1fac472
NC
202 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
203 if(mprotect(start, size, PROT_READ)) {
204 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
205 start, (unsigned long) size, errno);
206 }
207 }
5892a4d4
NC
208
209 free(slabs);
f1fac472
NC
210}
211
212STATIC void
213S_Slab_to_rw(pTHX_ void *op)
214{
215 I32 * const * const ptr = (I32 **) op;
216 I32 * const slab = ptr[-1];
7918f24d
NC
217
218 PERL_ARGS_ASSERT_SLAB_TO_RW;
219
f1fac472
NC
220 assert( ptr-1 > (I32 **) slab );
221 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
222 assert( *slab > 0 );
223 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
224 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
225 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
226 }
227}
fc97af9c
NC
228
229OP *
230Perl_op_refcnt_inc(pTHX_ OP *o)
231{
232 if(o) {
233 Slab_to_rw(o);
234 ++o->op_targ;
235 }
236 return o;
237
238}
239
240PADOFFSET
241Perl_op_refcnt_dec(pTHX_ OP *o)
242{
7918f24d 243 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
fc97af9c
NC
244 Slab_to_rw(o);
245 return --o->op_targ;
246}
f1fac472
NC
247#else
248# define Slab_to_rw(op)
249#endif
250
c7e45529
AE
251void
252Perl_Slab_Free(pTHX_ void *op)
238a4c30 253{
551405c4 254 I32 * const * const ptr = (I32 **) op;
aec46f14 255 I32 * const slab = ptr[-1];
7918f24d 256 PERL_ARGS_ASSERT_SLAB_FREE;
5a8e194f
NIS
257 assert( ptr-1 > (I32 **) slab );
258 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30 259 assert( *slab > 0 );
f1fac472 260 Slab_to_rw(op);
238a4c30 261 if (--(*slab) == 0) {
7e4e8c89
NC
262# ifdef NETWARE
263# define PerlMemShared PerlMem
264# endif
083fcd59 265
f1fac472 266#ifdef PERL_DEBUG_READONLY_OPS
782a40f1 267 U32 count = PL_slab_count;
f1fac472 268 /* Need to remove this slab from our list of slabs */
782a40f1 269 if (count) {
f1fac472
NC
270 while (count--) {
271 if (PL_slabs[count] == slab) {
5186cc12 272 dVAR;
f1fac472
NC
273 /* Found it. Move the entry at the end to overwrite it. */
274 DEBUG_m(PerlIO_printf(Perl_debug_log,
275 "Deallocate %p by moving %p from %lu to %lu\n",
276 PL_OpSlab,
277 PL_slabs[PL_slab_count - 1],
278 PL_slab_count, count));
279 PL_slabs[count] = PL_slabs[--PL_slab_count];
280 /* Could realloc smaller at this point, but probably not
281 worth it. */
fc97af9c
NC
282 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
283 perror("munmap failed");
284 abort();
285 }
286 break;
f1fac472 287 }
f1fac472
NC
288 }
289 }
290#else
083fcd59 291 PerlMemShared_free(slab);
f1fac472 292#endif
238a4c30
NIS
293 if (slab == PL_OpSlab) {
294 PL_OpSpace = 0;
295 }
296 }
b7dc083c 297}
b7dc083c 298#endif
e50aee73 299/*
ce6f1cbc 300 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 301 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 302 */
11343788 303#define CHECKOP(type,o) \
ce6f1cbc 304 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 305 ? ( op_free((OP*)o), \
cb77fdf0 306 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 307 (OP*)0 ) \
fc0dc3b3 308 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 309
e6438c1a 310#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 311
8b6b16e7 312STATIC const char*
cea2e8a9 313S_gv_ename(pTHX_ GV *gv)
4633a7c4 314{
46c461b5 315 SV* const tmpsv = sv_newmortal();
7918f24d
NC
316
317 PERL_ARGS_ASSERT_GV_ENAME;
318
bd61b366 319 gv_efullname3(tmpsv, gv, NULL);
8b6b16e7 320 return SvPV_nolen_const(tmpsv);
4633a7c4
LW
321}
322
76e3520e 323STATIC OP *
cea2e8a9 324S_no_fh_allowed(pTHX_ OP *o)
79072805 325{
7918f24d
NC
326 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
327
cea2e8a9 328 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 329 OP_DESC(o)));
11343788 330 return o;
79072805
LW
331}
332
76e3520e 333STATIC OP *
bfed75c6 334S_too_few_arguments(pTHX_ OP *o, const char *name)
79072805 335{
7918f24d
NC
336 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
337
cea2e8a9 338 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 339 return o;
79072805
LW
340}
341
76e3520e 342STATIC OP *
bfed75c6 343S_too_many_arguments(pTHX_ OP *o, const char *name)
79072805 344{
7918f24d
NC
345 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
346
cea2e8a9 347 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 348 return o;
79072805
LW
349}
350
76e3520e 351STATIC void
6867be6d 352S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
8990e307 353{
7918f24d
NC
354 PERL_ARGS_ASSERT_BAD_TYPE;
355
cea2e8a9 356 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 357 (int)n, name, t, OP_DESC(kid)));
8990e307
LW
358}
359
7a52d87a 360STATIC void
6867be6d 361S_no_bareword_allowed(pTHX_ const OP *o)
7a52d87a 362{
7918f24d
NC
363 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
364
eb8433b7
NC
365 if (PL_madskills)
366 return; /* various ok barewords are hidden in extra OP_NULL */
5a844595 367 qerror(Perl_mess(aTHX_
35c1215d 368 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
be2597df 369 SVfARG(cSVOPo_sv)));
7a52d87a
GS
370}
371
79072805
LW
372/* "register" allocation */
373
374PADOFFSET
d6447115 375Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
93a17b20 376{
97aff369 377 dVAR;
a0d0e21e 378 PADOFFSET off;
12bd6ede 379 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 380
7918f24d
NC
381 PERL_ARGS_ASSERT_ALLOCMY;
382
d6447115
NC
383 if (flags)
384 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
385 (UV)flags);
386
387 /* Until we're using the length for real, cross check that we're being
388 told the truth. */
389 assert(strlen(name) == len);
390
59f00321 391 /* complain about "my $<special_var>" etc etc */
d6447115 392 if (len &&
3edf23ff 393 !(is_our ||
155aba94 394 isALPHA(name[1]) ||
39e02b42 395 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
d6447115 396 (name[1] == '_' && (*name == '$' || len > 2))))
834a4ddd 397 {
6b58708b 398 /* name[2] is true if strlen(name) > 2 */
c4d0567e 399 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
d6447115
NC
400 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
401 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
aab6a793 402 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 403 } else {
d6447115 404 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
aab6a793 405 PL_parser->in_my == KEY_state ? "state" : "my"));
46fc3d4c 406 }
a0d0e21e 407 }
748a9306 408
dd2155a4 409 /* allocate a spare slot and store the name in that slot */
93a17b20 410
cca43f78 411 off = pad_add_name(name, len,
59cfed7d
NC
412 is_our ? padadd_OUR :
413 PL_parser->in_my == KEY_state ? padadd_STATE : 0,
12bd6ede 414 PL_parser->in_my_stash,
3edf23ff 415 (is_our
133706a6
RGS
416 /* $_ is always in main::, even with our */
417 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 418 : NULL
cca43f78 419 )
dd2155a4 420 );
a74073ad
DM
421 /* anon sub prototypes contains state vars should always be cloned,
422 * otherwise the state var would be shared between anon subs */
423
424 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
425 CvCLONE_on(PL_compcv);
426
dd2155a4 427 return off;
79072805
LW
428}
429
d2c837a0
DM
430/* free the body of an op without examining its contents.
431 * Always use this rather than FreeOp directly */
432
4136a0f7 433static void
d2c837a0
DM
434S_op_destroy(pTHX_ OP *o)
435{
436 if (o->op_latefree) {
437 o->op_latefreed = 1;
438 return;
439 }
440 FreeOp(o);
441}
442
c4bd3ae5
NC
443#ifdef USE_ITHREADS
444# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
445#else
446# define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
447#endif
d2c837a0 448
79072805
LW
449/* Destructor */
450
451void
864dbfa3 452Perl_op_free(pTHX_ OP *o)
79072805 453{
27da23d5 454 dVAR;
acb36ea4 455 OPCODE type;
79072805 456
85594c31 457 if (!o)
79072805 458 return;
670f3923
DM
459 if (o->op_latefreed) {
460 if (o->op_latefree)
461 return;
462 goto do_free;
463 }
79072805 464
67566ccd 465 type = o->op_type;
7934575e 466 if (o->op_private & OPpREFCOUNTED) {
67566ccd 467 switch (type) {
7934575e
GS
468 case OP_LEAVESUB:
469 case OP_LEAVESUBLV:
470 case OP_LEAVEEVAL:
471 case OP_LEAVE:
472 case OP_SCOPE:
473 case OP_LEAVEWRITE:
67566ccd
AL
474 {
475 PADOFFSET refcnt;
7934575e 476 OP_REFCNT_LOCK;
4026c95a 477 refcnt = OpREFCNT_dec(o);
7934575e 478 OP_REFCNT_UNLOCK;
bfd0ff22
NC
479 if (refcnt) {
480 /* Need to find and remove any pattern match ops from the list
481 we maintain for reset(). */
482 find_and_forget_pmops(o);
4026c95a 483 return;
67566ccd 484 }
bfd0ff22 485 }
7934575e
GS
486 break;
487 default:
488 break;
489 }
490 }
491
f37b8c3f
VP
492 /* Call the op_free hook if it has been set. Do it now so that it's called
493 * at the right time for refcounted ops, but still before all of the kids
494 * are freed. */
495 CALL_OPFREEHOOK(o);
496
11343788 497 if (o->op_flags & OPf_KIDS) {
6867be6d 498 register OP *kid, *nextkid;
11343788 499 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 500 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 501 op_free(kid);
85e6fe83 502 }
79072805 503 }
acb36ea4 504
fc97af9c
NC
505#ifdef PERL_DEBUG_READONLY_OPS
506 Slab_to_rw(o);
507#endif
508
acb36ea4
GS
509 /* COP* is not cleared by op_clear() so that we may track line
510 * numbers etc even after null() */
cc93af5f
RGS
511 if (type == OP_NEXTSTATE || type == OP_DBSTATE
512 || (type == OP_NULL /* the COP might have been null'ed */
513 && ((OPCODE)o->op_targ == OP_NEXTSTATE
514 || (OPCODE)o->op_targ == OP_DBSTATE))) {
acb36ea4 515 cop_free((COP*)o);
3235b7a3 516 }
acb36ea4 517
c53f1caa
RU
518 if (type == OP_NULL)
519 type = (OPCODE)o->op_targ;
520
acb36ea4 521 op_clear(o);
670f3923
DM
522 if (o->op_latefree) {
523 o->op_latefreed = 1;
524 return;
525 }
526 do_free:
238a4c30 527 FreeOp(o);
4d494880
DM
528#ifdef DEBUG_LEAKING_SCALARS
529 if (PL_op == o)
5f66b61c 530 PL_op = NULL;
4d494880 531#endif
acb36ea4 532}
79072805 533
93c66552
DM
534void
535Perl_op_clear(pTHX_ OP *o)
acb36ea4 536{
13137afc 537
27da23d5 538 dVAR;
7918f24d
NC
539
540 PERL_ARGS_ASSERT_OP_CLEAR;
541
eb8433b7
NC
542#ifdef PERL_MAD
543 /* if (o->op_madprop && o->op_madprop->mad_next)
544 abort(); */
3cc8d589
NC
545 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
546 "modification of a read only value" for a reason I can't fathom why.
547 It's the "" stringification of $_, where $_ was set to '' in a foreach
04a4d38e
NC
548 loop, but it defies simplification into a small test case.
549 However, commenting them out has caused ext/List/Util/t/weak.t to fail
550 the last test. */
3cc8d589
NC
551 /*
552 mad_free(o->op_madprop);
553 o->op_madprop = 0;
554 */
eb8433b7
NC
555#endif
556
557 retry:
11343788 558 switch (o->op_type) {
acb36ea4 559 case OP_NULL: /* Was holding old type, if any. */
eb8433b7 560 if (PL_madskills && o->op_targ != OP_NULL) {
61a59f30 561 o->op_type = (Optype)o->op_targ;
eb8433b7
NC
562 o->op_targ = 0;
563 goto retry;
564 }
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 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 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 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 1739 switch (type) {
1740 case OP_SASSIGN:
5196be3e 1741 if (o->op_type == OP_RV2GV)
3fe9a6f1 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 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 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
76e3520e 2346STATIC OP *
cea2e8a9 2347S_newDEFSVOP(pTHX)
54b9620d 2348{
97aff369 2349 dVAR;
f8f98e0a 2350 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
00b1698f 2351 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS
2352 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2353 }
2354 else {
551405c4 2355 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS
2356 o->op_targ = offset;
2357 return o;
2358 }
54b9620d
MB
2359}
2360
a0d0e21e 2361void
864dbfa3 2362Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2363{
97aff369 2364 dVAR;
7918f24d
NC
2365
2366 PERL_ARGS_ASSERT_NEWPROG;
2367
3280af22 2368 if (PL_in_eval) {
b295d113
TH
2369 if (PL_eval_root)
2370 return;
faef0170
HS
2371 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2372 ((PL_in_eval & EVAL_KEEPERR)
2373 ? OPf_SPECIAL : 0), o);
3280af22 2374 PL_eval_start = linklist(PL_eval_root);
7934575e
GS
2375 PL_eval_root->op_private |= OPpREFCOUNTED;
2376 OpREFCNT_set(PL_eval_root, 1);
3280af22 2377 PL_eval_root->op_next = 0;
a2efc822 2378 CALL_PEEP(PL_eval_start);
a0d0e21e
LW
2379 }
2380 else {
6be89cf9
AE
2381 if (o->op_type == OP_STUB) {
2382 PL_comppad_name = 0;
2383 PL_compcv = 0;
d2c837a0 2384 S_op_destroy(aTHX_ o);
a0d0e21e 2385 return;
6be89cf9 2386 }
3280af22
NIS
2387 PL_main_root = scope(sawparens(scalarvoid(o)));
2388 PL_curcop = &PL_compiling;
2389 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS
2390 PL_main_root->op_private |= OPpREFCOUNTED;
2391 OpREFCNT_set(PL_main_root, 1);
3280af22 2392 PL_main_root->op_next = 0;
a2efc822 2393 CALL_PEEP(PL_main_start);
3280af22 2394 PL_compcv = 0;
3841441e 2395
4fdae800 2396 /* Register with debugger */
84902520 2397 if (PERLDB_INTER) {
b96d8cd9 2398 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS
2399 if (cv) {
2400 dSP;
924508f0 2401 PUSHMARK(SP);
ad64d0ec 2402 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 2403 PUTBACK;
ad64d0ec 2404 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS
2405 }
2406 }
79072805 2407 }
79072805
LW
2408}
2409
2410OP *
864dbfa3 2411Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2412{
97aff369 2413 dVAR;
7918f24d
NC
2414
2415 PERL_ARGS_ASSERT_LOCALIZE;
2416
79072805 2417 if (o->op_flags & OPf_PARENS)
d2be0de5
YST
2418/* [perl #17376]: this appears to be premature, and results in code such as
2419 C< our(%x); > executing in list mode rather than void mode */
2420#if 0
79072805 2421 list(o);
d2be0de5 2422#else
6f207bd3 2423 NOOP;
d2be0de5 2424#endif
8990e307 2425 else {
f06b5848
DM
2426 if ( PL_parser->bufptr > PL_parser->oldbufptr
2427 && PL_parser->bufptr[-1] == ','
041457d9 2428 && ckWARN(WARN_PARENTHESIS))
64420d0d 2429 {
f06b5848 2430 char *s = PL_parser->bufptr;
bac662ee 2431 bool sigil = FALSE;
64420d0d 2432
8473848f 2433 /* some heuristics to detect a potential error */
bac662ee 2434 while (*s && (strchr(", \t\n", *s)))
64420d0d 2435 s++;
8473848f 2436
bac662ee
TS
2437 while (1) {
2438 if (*s && strchr("@$%*", *s) && *++s
2439 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2440 s++;
2441 sigil = TRUE;
2442 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2443 s++;
2444 while (*s && (strchr(", \t\n", *s)))
2445 s++;
2446 }
2447 else
2448 break;
2449 }
2450 if (sigil && (*s == ';' || *s == '=')) {
2451 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 2452 "Parentheses missing around \"%s\" list",
12bd6ede
DM
2453 lex
2454 ? (PL_parser->in_my == KEY_our
2455 ? "our"
2456 : PL_parser->in_my == KEY_state
2457 ? "state"
2458 : "my")
2459 : "local");
8473848f 2460 }
8990e307
LW
2461 }
2462 }
93a17b20 2463 if (lex)
eb64745e 2464 o = my(o);
93a17b20 2465 else
eb64745e 2466 o = mod(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM
2467 PL_parser->in_my = FALSE;
2468 PL_parser->in_my_stash = NULL;
eb64745e 2469 return o;
79072805
LW
2470}
2471
2472OP *
864dbfa3 2473Perl_jmaybe(pTHX_ OP *o)
79072805 2474{
7918f24d
NC
2475 PERL_ARGS_ASSERT_JMAYBE;
2476
79072805 2477 if (o->op_type == OP_LIST) {
fafc274c 2478 OP * const o2
d4c19fe8 2479 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
554b3eca 2480 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW
2481 }
2482 return o;
2483}
2484
1f676739 2485static OP *
b7783a12 2486S_fold_constants(pTHX_ register OP *o)
79072805 2487{
27da23d5 2488 dVAR;
001d637e 2489 register OP * VOL curop;
eb8433b7 2490 OP *newop;
8ea43dc8 2491 VOL I32 type = o->op_type;
e3cbe32f 2492 SV * VOL sv = NULL;
b7f7fd0b
NC
2493 int ret = 0;
2494 I32 oldscope;
2495 OP *old_next;
5f2d9966
DM
2496 SV * const oldwarnhook = PL_warnhook;
2497 SV * const olddiehook = PL_diehook;
c427f4d2 2498 COP not_compiling;
b7f7fd0b 2499 dJMPENV;
79072805 2500
7918f24d
NC
2501 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2502
22c35a8c 2503 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2504 scalar(o);
b162f9ea 2505 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2506 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2507
eac055e9
GS
2508 /* integerize op, unless it happens to be C<-foo>.
2509 * XXX should pp_i_negate() do magic string negation instead? */
2510 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2511 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2512 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2513 {
22c35a8c 2514 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2515 }
85e6fe83 2516
22c35a8c 2517 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW
2518 goto nope;
2519
de939608 2520 switch (type) {
7a52d87a
GS
2521 case OP_NEGATE:
2522 /* XXX might want a ck_negate() for this */
2523 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2524 break;
de939608
CS
2525 case OP_UCFIRST:
2526 case OP_LCFIRST:
2527 case OP_UC:
2528 case OP_LC:
69dcf70c
MB
2529 case OP_SLT:
2530 case OP_SGT:
2531 case OP_SLE:
2532 case OP_SGE:
2533 case OP_SCMP:
2de3dbcc
JH
2534 /* XXX what about the numeric ops? */
2535 if (PL_hints & HINT_LOCALE)
de939608 2536 goto nope;
553e7bb0 2537 break;
de939608
CS
2538 }
2539
13765c85 2540 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW
2541 goto nope; /* Don't try to run w/ errors */
2542
79072805 2543 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL
2544 const OPCODE type = curop->op_type;
2545 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2546 type != OP_LIST &&
2547 type != OP_SCALAR &&
2548 type != OP_NULL &&
2549 type != OP_PUSHMARK)
7a52d87a 2550 {
79072805
LW
2551 goto nope;
2552 }
2553 }
2554
2555 curop = LINKLIST(o);
b7f7fd0b 2556 old_next = o->op_next;
79072805 2557 o->op_next = 0;
533c011a 2558 PL_op = curop;
b7f7fd0b
NC
2559
2560 oldscope = PL_scopestack_ix;
edb2152a 2561 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 2562
c427f4d2
NC
2563 /* Verify that we don't need to save it: */
2564 assert(PL_curcop == &PL_compiling);
2565 StructCopy(&PL_compiling, &not_compiling, COP);
2566 PL_curcop = &not_compiling;
2567 /* The above ensures that we run with all the correct hints of the
2568 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2569 assert(IN_PERL_RUNTIME);
5f2d9966
DM
2570 PL_warnhook = PERL_WARNHOOK_FATAL;
2571 PL_diehook = NULL;
b7f7fd0b
NC
2572 JMPENV_PUSH(ret);
2573
2574 switch (ret) {
2575 case 0:
2576 CALLRUNOPS(aTHX);
2577 sv = *(PL_stack_sp--);
2578 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2579 pad_swipe(o->op_targ, FALSE);
2580 else if (SvTEMP(sv)) { /* grab mortal temp? */
2581 SvREFCNT_inc_simple_void(sv);
2582 SvTEMP_off(sv);
2583 }
2584 break;
2585 case 3:
2586 /* Something tried to die. Abandon constant folding. */
2587 /* Pretend the error never happened. */
ab69dbc2 2588 CLEAR_ERRSV();
b7f7fd0b
NC
2589 o->op_next = old_next;
2590 break;
2591 default:
2592 JMPENV_POP;
5f2d9966
DM
2593 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2594 PL_warnhook = oldwarnhook;
2595 PL_diehook = olddiehook;
2596 /* XXX note that this croak may fail as we've already blown away
2597 * the stack - eg any nested evals */
b7f7fd0b
NC
2598 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2599 }
b7f7fd0b 2600 JMPENV_POP;
5f2d9966
DM
2601 PL_warnhook = oldwarnhook;
2602 PL_diehook = olddiehook;
c427f4d2 2603 PL_curcop = &PL_compiling;
edb2152a
NC
2604
2605 if (PL_scopestack_ix > oldscope)
2606 delete_eval_scope();
eb8433b7 2607
b7f7fd0b
NC
2608 if (ret)
2609 goto nope;
2610
eb8433b7 2611#ifndef PERL_MAD
79072805 2612 op_free(o);
eb8433b7 2613#endif
de5e01c2 2614 assert(sv);
79072805 2615 if (type == OP_RV2GV)
159b6efe 2616 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 2617 else
ad64d0ec 2618 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
eb8433b7
NC
2619 op_getmad(o,newop,'f');
2620 return newop;
aeea060c 2621
b7f7fd0b 2622 nope:
79072805
LW
2623 return o;
2624}
2625
1f676739 2626static OP *
b7783a12 2627S_gen_constant_list(pTHX_ register OP *o)
79072805 2628{
27da23d5 2629 dVAR;
79072805 2630 register OP *curop;
6867be6d 2631 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2632
a0d0e21e 2633 list(o);
13765c85 2634 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW
2635 return o; /* Don't attempt to run with errors */
2636
533c011a 2637 PL_op = curop = LINKLIST(o);
a0d0e21e 2638 o->op_next = 0;
a2efc822 2639 CALL_PEEP(curop);
cea2e8a9
GS
2640 pp_pushmark();
2641 CALLRUNOPS(aTHX);
533c011a 2642 PL_op = curop;
78c72037
NC
2643 assert (!(curop->op_flags & OPf_SPECIAL));
2644 assert(curop->op_type == OP_RANGE);
cea2e8a9 2645 pp_anonlist();
3280af22 2646 PL_tmps_floor = oldtmps_floor;
79072805
LW
2647
2648 o->op_type = OP_RV2AV;
22c35a8c 2649 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG
2650 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2651 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2652 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2653 curop = ((UNOP*)o)->op_first;
b37c2d43 2654 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC
2655#ifdef PERL_MAD
2656 op_getmad(curop,o,'O');
2657#else
79072805 2658 op_free(curop);
eb8433b7 2659#endif
79072805
LW
2660 linklist(o);
2661 return list(o);
2662}
2663
2664OP *
864dbfa3 2665Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2666{
27da23d5 2667 dVAR;
11343788 2668 if (!o || o->op_type != OP_LIST)
5f66b61c 2669 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 2670 else
5dc0d613 2671 o->op_flags &= ~OPf_WANT;
79072805 2672
22c35a8c 2673 if (!(PL_opargs[type] & OA_MARK))
93c66552 2674 op_null(cLISTOPo->op_first);
8990e307 2675
eb160463 2676 o->op_type = (OPCODE)type;
22c35a8c 2677 o->op_ppaddr = PL_ppaddr[type];
11343788 2678 o->op_flags |= flags;
79072805 2679
11343788 2680 o = CHECKOP(type, o);
fe2774ed 2681 if (o->op_type != (unsigned)type)
11343788 2682 return o;
79072805 2683
11343788 2684 return fold_constants(o);
79072805
LW
2685}
2686
2687/* List constructors */
2688
2689OP *
864dbfa3 2690Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2691{
2692 if (!first)
2693 return last;
8990e307
LW
2694
2695 if (!last)
79072805 2696 return first;
8990e307 2697
fe2774ed 2698 if (first->op_type != (unsigned)type
155aba94
GS
2699 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2700 {
2701 return newLISTOP(type, 0, first, last);
2702 }
79072805 2703
a0d0e21e
LW
2704 if (first->op_flags & OPf_KIDS)
2705 ((LISTOP*)first)->op_last->op_sibling = last;
2706 else {
2707 first->op_flags |= OPf_KIDS;
2708 ((LISTOP*)first)->op_first = last;
2709 }
2710 ((LISTOP*)first)->op_last = last;
a0d0e21e 2711 return first;
79072805
LW
2712}
2713
2714OP *
864dbfa3 2715Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW
2716{
2717 if (!first)
2718 return (OP*)last;
8990e307
LW
2719
2720 if (!last)
79072805 2721 return (OP*)first;
8990e307 2722
fe2774ed 2723 if (first->op_type != (unsigned)type)
79072805 2724 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2725
fe2774ed 2726 if (last->op_type != (unsigned)type)
79072805
LW
2727 return append_elem(type, (OP*)first, (OP*)last);
2728
2729 first->op_last->op_sibling = last->op_first;
2730 first->op_last = last->op_last;
117dada2 2731 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2732
eb8433b7
NC
2733#ifdef PERL_MAD
2734 if (last->op_first && first->op_madprop) {
2735 MADPROP *mp = last->op_first->op_madprop;
2736 if (mp) {
2737 while (mp->mad_next)
2738 mp = mp->mad_next;
2739 mp->mad_next = first->op_madprop;
2740 }
2741 else {
2742 last->op_first->op_madprop = first->op_madprop;
2743 }
2744 }
2745 first->op_madprop = last->op_madprop;
2746 last->op_madprop = 0;
2747#endif
2748
d2c837a0 2749 S_op_destroy(aTHX_ (OP*)last);
238a4c30 2750
79072805
LW
2751 return (OP*)first;
2752}
2753
2754OP *
864dbfa3 2755Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2756{
2757 if (!first)
2758 return last;
8990e307
LW
2759
2760 if (!last)
79072805 2761 return first;
8990e307 2762
fe2774ed 2763 if (last->op_type == (unsigned)type) {
8990e307
LW
2764 if (type == OP_LIST) { /* already a PUSHMARK there */
2765 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2766 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC
2767 if (!(first->op_flags & OPf_PARENS))
2768 last->op_flags &= ~OPf_PARENS;
8990e307
LW
2769 }
2770 else {
2771 if (!(last->op_flags & OPf_KIDS)) {
2772 ((LISTOP*)last)->op_last = first;
2773 last->op_flags |= OPf_KIDS;
2774 }
2775 first->op_sibling = ((LISTOP*)last)->op_first;
2776 ((LISTOP*)last)->op_first = first;
79072805 2777 }
117dada2 2778 last->op_flags |= OPf_KIDS;
79072805
LW
2779 return last;
2780 }
2781
2782 return newLISTOP(type, 0, first, last);
2783}
2784
2785/* Constructors */
2786
eb8433b7
NC
2787#ifdef PERL_MAD
2788
2789TOKEN *
2790Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2791{
2792 TOKEN *tk;
99129197 2793 Newxz(tk, 1, TOKEN);
eb8433b7
NC
2794 tk->tk_type = (OPCODE)optype;
2795 tk->tk_type = 12345;
2796 tk->tk_lval = lval;
2797 tk->tk_mad = madprop;
2798 return tk;
2799}
2800
2801void
2802Perl_token_free(pTHX_ TOKEN* tk)
2803{
7918f24d
NC
2804 PERL_ARGS_ASSERT_TOKEN_FREE;
2805
eb8433b7
NC
2806 if (tk->tk_type != 12345)
2807 return;
2808 mad_free(tk->tk_mad);
2809 Safefree(tk);
2810}
2811
2812void
2813Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2814{
2815 MADPROP* mp;
2816 MADPROP* tm;
7918f24d
NC
2817
2818 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2819
eb8433b7
NC
2820 if (tk->tk_type != 12345) {
2821 Perl_warner(aTHX_ packWARN(WARN_MISC),
2822 "Invalid TOKEN object ignored");
2823 return;
2824 }
2825 tm = tk->tk_mad;
2826 if (!tm)
2827 return;
2828
2829 /* faked up qw list? */
2830 if (slot == '(' &&
2831 tm->mad_type == MAD_SV &&
d503a9ba 2832 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC
2833 slot = 'x';
2834
2835 if (o) {
2836 mp = o->op_madprop;
2837 if (mp) {
2838 for (;;) {
2839 /* pretend constant fold didn't happen? */
2840 if (mp->mad_key == 'f' &&
2841 (o->op_type == OP_CONST ||
2842 o->op_type == OP_GV) )
2843 {
2844 token_getmad(tk,(OP*)mp->mad_val,slot);
2845 return;
2846 }
2847 if (!mp->mad_next)
2848 break;
2849 mp = mp->mad_next;
2850 }
2851 mp->mad_next = tm;
2852 mp = mp->mad_next;
2853 }
2854 else {
2855 o->op_madprop = tm;
2856 mp = o->op_madprop;
2857 }
2858 if (mp->mad_key == 'X')
2859 mp->mad_key = slot; /* just change the first one */
2860
2861 tk->tk_mad = 0;
2862 }
2863 else
2864 mad_free(tm);
2865 Safefree(tk);
2866}
2867
2868void
2869Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2870{
2871 MADPROP* mp;
2872 if (!from)
2873 return;
2874 if (o) {
2875 mp = o->op_madprop;
2876 if (mp) {
2877 for (;;) {
2878 /* pretend constant fold didn't happen? */
2879 if (mp->mad_key == 'f' &&
2880 (o->op_type == OP_CONST ||
2881 o->op_type == OP_GV) )
2882 {
2883 op_getmad(from,(OP*)mp->mad_val,slot);
2884 return;
2885 }
2886 if (!mp->mad_next)
2887 break;
2888 mp = mp->mad_next;
2889 }
2890 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2891 }
2892 else {
2893 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2894 }
2895 }
2896}
2897
2898void
2899Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2900{
2901 MADPROP* mp;
2902 if (!from)
2903 return;
2904 if (o) {
2905 mp = o->op_madprop;
2906 if (mp) {
2907 for (;;) {
2908 /* pretend constant fold didn't happen? */
2909 if (mp->mad_key == 'f' &&
2910 (o->op_type == OP_CONST ||
2911 o->op_type == OP_GV) )
2912 {
2913 op_getmad(from,(OP*)mp->mad_val,slot);
2914 return;
2915 }
2916 if (!mp->mad_next)
2917 break;
2918 mp = mp->mad_next;
2919 }
2920 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2921 }
2922 else {
2923 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2924 }
2925 }
2926 else {
99129197
NC
2927 PerlIO_printf(PerlIO_stderr(),
2928 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC
2929 op_free(from);
2930 }
2931}
2932
2933void
2934Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2935{
2936 MADPROP* tm;
2937 if (!mp || !o)
2938 return;
2939 if (slot)
2940 mp->mad_key = slot;
2941 tm = o->op_madprop;
2942 o->op_madprop = mp;
2943 for (;;) {
2944 if (!mp->mad_next)
2945 break;
2946 mp = mp->mad_next;
2947 }
2948 mp->mad_next = tm;
2949}
2950
2951void
2952Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2953{
2954 if (!o)
2955 return;
2956 addmad(tm, &(o->op_madprop), slot);
2957}
2958
2959void
2960Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2961{
2962 MADPROP* mp;
2963 if (!tm || !root)
2964 return;
2965 if (slot)
2966 tm->mad_key = slot;
2967 mp = *root;
2968 if (!mp) {
2969 *root = tm;
2970 return;
2971 }
2972 for (;;) {
2973 if (!mp->mad_next)
2974 break;
2975 mp = mp->mad_next;
2976 }
2977 mp->mad_next = tm;
2978}
2979
2980MADPROP *
2981Perl_newMADsv(pTHX_ char key, SV* sv)
2982{
7918f24d
NC
2983 PERL_ARGS_ASSERT_NEWMADSV;
2984
eb8433b7
NC
2985 return newMADPROP(key, MAD_SV, sv, 0);
2986}
2987
2988MADPROP *
d503a9ba 2989Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7
NC
2990{
2991 MADPROP *mp;
99129197 2992 Newxz(mp, 1, MADPROP);
eb8433b7
NC
2993 mp->mad_next = 0;
2994 mp->mad_key = key;
2995 mp->mad_vlen = vlen;
2996 mp->mad_type = type;
2997 mp->mad_val = val;
2998/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2999 return mp;
3000}
3001
3002void
3003Perl_mad_free(pTHX_ MADPROP* mp)
3004{
3005/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3006 if (!mp)
3007 return;
3008 if (mp->mad_next)
3009 mad_free(mp->mad_next);
bc177e6b 3010/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC
3011 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3012 switch (mp->mad_type) {
3013 case MAD_NULL:
3014 break;
3015 case MAD_PV:
3016 Safefree((char*)mp->mad_val);
3017 break;
3018 case MAD_OP:
3019 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3020 op_free((OP*)mp->mad_val);
3021 break;
3022 case MAD_SV:
ad64d0ec 3023 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC
3024 break;
3025 default:
3026 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3027 break;
3028 }
3029 Safefree(mp);
3030}
3031
3032#endif
3033
79072805 3034OP *
864dbfa3 3035Perl_newNULLLIST(pTHX)
79072805 3036{
8990e307
LW
3037 return newOP(OP_STUB, 0);
3038}
3039
1f676739 3040static OP *
b7783a12 3041S_force_list(pTHX_ OP *o)
8990e307 3042{
11343788 3043 if (!o || o->op_type != OP_LIST)
5f66b61c 3044 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 3045 op_null(o);
11343788 3046 return o;
79072805
LW
3047}
3048
3049OP *
864dbfa3 3050Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3051{
27da23d5 3052 dVAR;
79072805
LW
3053 LISTOP *listop;
3054
e69777c1
GG
3055 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3056
b7dc083c 3057 NewOp(1101, listop, 1, LISTOP);
79072805 3058
eb160463 3059 listop->op_type = (OPCODE)type;
22c35a8c 3060 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM
3061 if (first || last)
3062 flags |= OPf_KIDS;
eb160463 3063 listop->op_flags = (U8)flags;
79072805
LW
3064
3065 if (!last && first)
3066 last = first;
3067 else if (!first && last)
3068 first = last;
8990e307
LW
3069 else if (first)
3070 first->op_sibling = last;
79072805
LW
3071 listop->op_first = first;
3072 listop->op_last = last;
8990e307 3073 if (type == OP_LIST) {
551405c4 3074 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW
3075 pushop->op_sibling = first;
3076 listop->op_first = pushop;
3077 listop->op_flags |= OPf_KIDS;
3078 if (!last)
3079 listop->op_last = pushop;
3080 }
79072805 3081
463d09e6 3082 return CHECKOP(type, listop);
79072805
LW
3083}
3084
3085OP *
864dbfa3 3086Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 3087{
27da23d5 3088 dVAR;
11343788 3089 OP *o;
e69777c1
GG
3090
3091 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3092 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3093 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3094 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3095
b7dc083c 3096 NewOp(1101, o, 1, OP);
eb160463 3097 o->op_type = (OPCODE)type;
22c35a8c 3098 o->op_ppaddr = PL_ppaddr[type];
eb160463 3099 o->op_flags = (U8)flags;
670f3923
DM
3100 o->op_latefree = 0;
3101 o->op_latefreed = 0;
7e5d8ed2 3102 o->op_attached = 0;
79072805 3103
11343788 3104 o->op_next = o;
eb160463 3105 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 3106 if (PL_opargs[type] & OA_RETSCALAR)
11343788 3107 scalar(o);
22c35a8c 3108 if (PL_opargs[type] & OA_TARGET)
11343788
MB
3109 o->op_targ = pad_alloc(type, SVs_PADTMP);
3110 return CHECKOP(type, o);
79072805
LW
3111}
3112
3113OP *
864dbfa3 3114Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 3115{
27da23d5 3116 dVAR;
79072805
LW
3117 UNOP *unop;
3118
e69777c1
GG
3119 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3120 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3121 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3122 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3123 || type == OP_SASSIGN
32e2a35d 3124 || type == OP_ENTERTRY
e69777c1
GG
3125 || type == OP_NULL );
3126
93a17b20 3127 if (!first)
aeea060c 3128 first = newOP(OP_STUB, 0);
22c35a8c 3129 if (PL_opargs[type] & OA_MARK)
8990e307 3130 first = force_list(first);
93a17b20 3131
b7dc083c 3132 NewOp(1101, unop, 1, UNOP);
eb160463 3133 unop->op_type = (OPCODE)type;
22c35a8c 3134 unop->op_ppaddr = PL_ppaddr[type];
79072805 3135 unop->op_first = first;
585ec06d 3136 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 3137 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 3138 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW
3139 if (unop->op_next)
3140 return (OP*)unop;
3141
a0d0e21e 3142 return fold_constants((OP *) unop);
79072805
LW
3143}
3144
3145OP *
864dbfa3 3146Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3147{
27da23d5 3148 dVAR;
79072805 3149 BINOP *binop;
e69777c1
GG
3150
3151 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3152 || type == OP_SASSIGN || type == OP_NULL );
3153
b7dc083c 3154 NewOp(1101, binop, 1, BINOP);
79072805
LW
3155
3156 if (!first)
3157 first = newOP(OP_NULL, 0);
3158
eb160463 3159 binop->op_type = (OPCODE)type;
22c35a8c 3160 binop->op_ppaddr = PL_ppaddr[type];
79072805 3161 binop->op_first = first;
585ec06d 3162 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW
3163 if (!last) {
3164 last = first;
eb160463 3165 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW
3166 }
3167 else {
eb160463 3168 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW
3169 first->op_sibling = last;
3170 }
3171
e50aee73 3172 binop = (BINOP*)CHECKOP(type, binop);
eb160463 3173 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW
3174 return (OP*)binop;
3175
7284ab6f 3176 binop->op_last = binop->op_first->op_sibling;
79072805 3177
a0d0e21e 3178 return fold_constants((OP *)binop);
79072805
LW
3179}
3180
5f66b61c
AL
3181static int uvcompare(const void *a, const void *b)
3182 __attribute__nonnull__(1)
3183 __attribute__nonnull__(2)
3184 __attribute__pure__;
abb2c242 3185static int uvcompare(const void *a, const void *b)
2b9d42f0 3186{
e1ec3a88 3187 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 3188 return -1;
e1ec3a88 3189 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 3190 return 1;
e1ec3a88 3191 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 3192 return -1;
e1ec3a88 3193 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 3194 return 1;
a0ed51b3
LW
3195 return 0;
3196}
3197
0d86688d
NC
3198static OP *
3199S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 3200{
97aff369 3201 dVAR;
2d03de9c 3202 SV * const tstr = ((SVOP*)expr)->op_sv;
fbbb0949
DM
3203 SV * const rstr =
3204#ifdef PERL_MAD
3205 (repl->op_type == OP_NULL)
3206 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3207#endif
3208 ((SVOP*)repl)->op_sv;
463ee0b2
LW
3209 STRLEN tlen;
3210 STRLEN rlen;
5c144d81
NC
3211 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3212 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW
3213 register I32 i;
3214 register I32 j;
9b877dbb 3215 I32 grows = 0;
79072805
LW
3216 register short *tbl;
3217
551405c4
AL
3218 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3219 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3220 I32 del = o->op_private & OPpTRANS_DELETE;
043e41b8 3221 SV* swash;
7918f24d
NC
3222
3223 PERL_ARGS_ASSERT_PMTRANS;
3224
800b4dc4 3225 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 3226
036b4402
GS
3227 if (SvUTF8(tstr))
3228 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS
3229
3230 if (SvUTF8(rstr))
036b4402 3231 o->op_private |= OPpTRANS_TO_UTF;
79072805 3232
a0ed51b3 3233 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 3234 SV* const listsv = newSVpvs("# comment\n");
c445ea15 3235 SV* transv = NULL;
5c144d81
NC
3236 const U8* tend = t + tlen;
3237 const U8* rend = r + rlen;
ba210ebe 3238 STRLEN ulen;
84c133a0
RB
3239 UV tfirst = 1;
3240 UV tlast = 0;
3241 IV tdiff;
3242 UV rfirst = 1;
3243 UV rlast = 0;
3244 IV rdiff;
3245 IV diff;
a0ed51b3
LW
3246 I32 none = 0;
3247 U32 max = 0;
3248 I32 bits;
a0ed51b3 3249 I32 havefinal = 0;
9c5ffd7c 3250 U32 final = 0;
551405c4
AL
3251 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3252 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH
3253 U8* tsave = NULL;
3254 U8* rsave = NULL;
9f7f3913 3255 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH
3256
3257 if (!from_utf) {
3258 STRLEN len = tlen;
5c144d81 3259 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH
3260 tend = t + len;
3261 }
3262 if (!to_utf && rlen) {
3263 STRLEN len = rlen;
5c144d81 3264 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH
3265 rend = r + len;
3266 }
a0ed51b3 3267
2b9d42f0
NIS
3268/* There are several snags with this code on EBCDIC:
3269 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3270 2. scan_const() in toke.c has encoded chars in native encoding which makes
3271 ranges at least in EBCDIC 0..255 range the bottom odd.
3272*/
3273
a0ed51b3 3274 if (complement) {
89ebb4a3 3275 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 3276 UV *cp;
a0ed51b3 3277 UV nextmin = 0;
a02a5408 3278 Newx(cp, 2*tlen, UV);
a0ed51b3 3279 i = 0;
396482e1 3280 transv = newSVpvs("");
a0ed51b3 3281 while (t < tend) {
9f7f3913 3282 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS
3283 t += ulen;
3284 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 3285 t++;
9f7f3913 3286 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 3287 t += ulen;
a0ed51b3 3288 }
2b9d42f0
NIS
3289 else {
3290 cp[2*i+1] = cp[2*i];
3291 }
3292 i++;
a0ed51b3 3293 }
2b9d42f0 3294 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 3295 for (j = 0; j < i; j++) {
2b9d42f0 3296 UV val = cp[2*j];
a0ed51b3
LW
3297 diff = val - nextmin;
3298 if (diff > 0) {
9041c2e3 3299 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3300 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 3301 if (diff > 1) {
2b9d42f0 3302 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 3303 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 3304 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 3305 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW
3306 }
3307 }
2b9d42f0 3308 val = cp[2*j+1];
a0ed51b3
LW
3309 if (val >= nextmin)
3310 nextmin = val + 1;
3311 }
9041c2e3 3312 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 3313 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS
3314 {
3315 U8 range_mark = UTF_TO_NATIVE(0xff);
3316 sv_catpvn(transv, (char *)&range_mark, 1);
3317 }
b851fbc1
JH
3318 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3319 UNICODE_ALLOW_SUPER);
dfe13c55 3320 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 3321 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW
3322 tlen = SvCUR(transv);
3323 tend = t + tlen;
455d824a 3324 Safefree(cp);
a0ed51b3
LW
3325 }
3326 else if (!rlen && !del) {
3327 r = t; rlen = tlen; rend = tend;
4757a243
LW
3328 }
3329 if (!squash) {
05d340b8 3330 if ((!rlen && !del) || t == r ||
12ae5dfc 3331 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 3332 {
4757a243 3333 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 3334 }
a0ed51b3
LW
3335 }
3336
3337 while (t < tend || tfirst <= tlast) {
3338 /* see if we need more "t" chars */
3339 if (tfirst > tlast) {
9f7f3913 3340 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 3341 t += ulen;
2b9d42f0 3342 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3343 t++;
9f7f3913 3344 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW
3345 t += ulen;
3346 }
3347 else
3348 tlast = tfirst;
3349 }
3350
3351 /* now see if we need more "r" chars */
3352 if (rfirst > rlast) {
3353 if (r < rend) {
9f7f3913 3354 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 3355 r += ulen;
2b9d42f0 3356 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 3357 r++;
9f7f3913 3358 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW
3359 r += ulen;
3360 }
3361 else
3362 rlast = rfirst;
3363 }
3364 else {
3365 if (!havefinal++)
3366 final = rlast;
3367 rfirst = rlast = 0xffffffff;
3368 }
3369 }
3370
3371 /* now see which range will peter our first, if either. */
3372 tdiff = tlast - tfirst;
3373 rdiff = rlast - rfirst;
3374
3375 if (tdiff <= rdiff)
3376 diff = tdiff;
3377 else
3378 diff = rdiff;
3379
3380 if (rfirst == 0xffffffff) {
3381 diff = tdiff; /* oops, pretend rdiff is infinite */
3382 if (diff > 0)
894356b3
GS
3383 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3384 (long)tfirst, (long)tlast);
a0ed51b3 3385 else
894356b3 3386 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW
3387 }
3388 else {
3389 if (diff > 0)
894356b3
GS
3390 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3391 (long)tfirst, (long)(tfirst + diff),
3392 (long)rfirst);
a0ed51b3 3393 else
894356b3
GS
3394 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3395 (long)tfirst, (long)rfirst);
a0ed51b3
LW
3396
3397 if (rfirst + diff > max)
3398 max = rfirst + diff;
9b877dbb 3399 if (!grows)
45005bfb
JH
3400 grows = (tfirst < rfirst &&
3401 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3402 rfirst += diff + 1;
a0ed51b3
LW
3403 }
3404 tfirst += diff + 1;
3405 }
3406
3407 none = ++max;
3408 if (del)
3409 del = ++max;
3410
3411 if (max > 0xffff)
3412 bits = 32;
3413 else if (max > 0xff)
3414 bits = 16;
3415 else
3416 bits = 8;
3417
ea71c68d 3418 PerlMemShared_free(cPVOPo->op_pv);
b3123a61 3419 cPVOPo->op_pv = NULL;
043e41b8 3420
ad64d0ec 3421 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
043e41b8
DM
3422#ifdef USE_ITHREADS
3423 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3424 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3425 PAD_SETSV(cPADOPo->op_padix, swash);
3426 SvPADTMP_on(swash);
a5446a64 3427 SvREADONLY_on(swash);
043e41b8
DM
3428#else
3429 cSVOPo->op_sv = swash;
3430#endif
a0ed51b3 3431 SvREFCNT_dec(listsv);
b37c2d43 3432 SvREFCNT_dec(transv);
a0ed51b3 3433
45005bfb 3434 if (!del && havefinal && rlen)
85fbaab2 3435 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
b448e4fe 3436 newSVuv((UV)final), 0);
a0ed51b3 3437
9b877dbb 3438 if (grows)
a0ed51b3
LW
3439 o->op_private |= OPpTRANS_GROWS;
3440
b37c2d43
AL
3441 Safefree(tsave);
3442 Safefree(rsave);
9b877dbb 3443
eb8433b7
NC
3444#ifdef PERL_MAD
3445 op_getmad(expr,o,'e');
3446 op_getmad(repl,o,'r');
3447#else
a0ed51b3
LW
3448 op_free(expr);
3449 op_free(repl);
eb8433b7 3450#endif
a0ed51b3
LW
3451 return o;
3452 }
3453
3454 tbl = (short*)cPVOPo->op_pv;
79072805
LW
3455 if (complement) {
3456 Zero(tbl, 256, short);
eb160463 3457 for (i = 0; i < (I32)tlen; i++)
ec49126f 3458 tbl[t[i]] = -1;
79072805
LW
3459 for (i = 0, j = 0; i < 256; i++) {
3460 if (!tbl[i]) {
eb160463 3461 if (j >= (I32)rlen) {
a0ed51b3 3462 if (del)
79072805
LW
3463 tbl[i] = -2;
3464 else if (rlen)
ec49126f 3465 tbl[i] = r[j-1];
79072805 3466 else
eb160463 3467 tbl[i] = (short)i;
79072805 3468 }
9b877dbb
IH
3469 else {
3470 if (i < 128 && r[j] >= 128)
3471 grows = 1;
ec49126f 3472 tbl[i] = r[j++];
9b877dbb 3473 }
79072805
LW
3474 }
3475 }
05d340b8
JH
3476 if (!del) {
3477 if (!rlen) {
3478 j = rlen;
3479 if (!squash)
3480 o->op_private |= OPpTRANS_IDENTICAL;
3481 }
eb160463 3482 else if (j >= (I32)rlen)
05d340b8 3483 j = rlen - 1;
10db182f 3484 else {
aa1f7c5b
JH
3485 tbl =
3486 (short *)
3487 PerlMemShared_realloc(tbl,
3488 (0x101+rlen-j) * sizeof(short));
10db182f
YO
3489 cPVOPo->op_pv = (char*)tbl;
3490 }
585ec06d 3491 tbl[0x100] = (short)(rlen - j);
eb160463 3492 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH
3493 tbl[0x101+i] = r[j+i];
3494 }
79072805
LW
3495 }
3496 else {
a0ed51b3 3497 if (!rlen && !del) {
79072805 3498 r = t; rlen = tlen;
5d06d08e 3499 if (!squash)
4757a243 3500 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3501 }
94bfe852
RGS
3502 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3503 o->op_private |= OPpTRANS_IDENTICAL;
3504 }
79072805
LW
3505 for (i = 0; i < 256; i++)
3506 tbl[i] = -1;
eb160463
GS
3507 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3508 if (j >= (I32)rlen) {
a0ed51b3 3509 if (del) {
ec49126f 3510 if (tbl[t[i]] == -1)
3511 tbl[t[i]] = -2;
79072805
LW
3512 continue;
3513 }
3514 --j;
3515 }
9b877dbb
IH
3516 if (tbl[t[i]] == -1) {
3517 if (t[i] < 128 && r[j] >= 128)
3518 grows = 1;
ec49126f 3519 tbl[t[i]] = r[j];
9b877dbb 3520 }
79072805
LW
3521 }
3522 }
b08e453b 3523
a2a5de95
NC
3524 if(del && rlen == tlen) {
3525 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3526 } else if(rlen > tlen) {
3527 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
b08e453b
RB
3528 }
3529
9b877dbb
IH
3530 if (grows)
3531 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC
3532#ifdef PERL_MAD
3533 op_getmad(expr,o,'e');
3534 op_getmad(repl,o,'r');
3535#else
79072805
LW
3536 op_free(expr);
3537 op_free(repl);
eb8433b7 3538#endif
79072805 3539
11343788 3540 return o;
79072805
LW
3541}
3542
3543OP *
864dbfa3 3544Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 3545{
27da23d5 3546 dVAR;
79072805
LW
3547 PMOP *pmop;
3548
e69777c1
GG
3549 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3550
b7dc083c 3551 NewOp(1101, pmop, 1, PMOP);
eb160463 3552 pmop->op_type = (OPCODE)type;
22c35a8c 3553 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS
3554 pmop->op_flags = (U8)flags;
3555 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 3556
3280af22 3557 if (PL_hints & HINT_RE_TAINT)
c737faaf 3558 pmop->op_pmflags |= PMf_RETAINT;
3280af22 3559 if (PL_hints & HINT_LOCALE)
c737faaf
YO
3560 pmop->op_pmflags |= PMf_LOCALE;
3561
36477c24 3562
debc9467 3563#ifdef USE_ITHREADS
402d2eb1
NC
3564 assert(SvPOK(PL_regex_pad[0]));
3565 if (SvCUR(PL_regex_pad[0])) {
3566 /* Pop off the "packed" IV from the end. */
3567 SV *const repointer_list = PL_regex_pad[0];
3568 const char *p = SvEND(repointer_list) - sizeof(IV);
3569 const IV offset = *((IV*)p);
3570
3571 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3572
3573 SvEND_set(repointer_list, p);
3574
110f3028 3575 pmop->op_pmoffset = offset;
14a49a24
NC
3576 /* This slot should be free, so assert this: */