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