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