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