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