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