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