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