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