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