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