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