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