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