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