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