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