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